From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- libgfortran/generated/_abs_c10.F90 | 46 +++ libgfortran/generated/_abs_c16.F90 | 46 +++ libgfortran/generated/_abs_c4.F90 | 46 +++ libgfortran/generated/_abs_c8.F90 | 46 +++ libgfortran/generated/_abs_i16.F90 | 46 +++ libgfortran/generated/_abs_i4.F90 | 46 +++ libgfortran/generated/_abs_i8.F90 | 46 +++ libgfortran/generated/_abs_r10.F90 | 46 +++ libgfortran/generated/_abs_r16.F90 | 46 +++ libgfortran/generated/_abs_r4.F90 | 46 +++ libgfortran/generated/_abs_r8.F90 | 46 +++ libgfortran/generated/_acos_r10.F90 | 46 +++ libgfortran/generated/_acos_r16.F90 | 46 +++ libgfortran/generated/_acos_r4.F90 | 46 +++ libgfortran/generated/_acos_r8.F90 | 46 +++ libgfortran/generated/_acosh_r10.F90 | 46 +++ libgfortran/generated/_acosh_r16.F90 | 46 +++ libgfortran/generated/_acosh_r4.F90 | 46 +++ libgfortran/generated/_acosh_r8.F90 | 46 +++ libgfortran/generated/_aimag_c10.F90 | 46 +++ libgfortran/generated/_aimag_c16.F90 | 46 +++ libgfortran/generated/_aimag_c4.F90 | 46 +++ libgfortran/generated/_aimag_c8.F90 | 46 +++ libgfortran/generated/_aint_r10.F90 | 46 +++ libgfortran/generated/_aint_r16.F90 | 46 +++ libgfortran/generated/_aint_r4.F90 | 46 +++ libgfortran/generated/_aint_r8.F90 | 46 +++ libgfortran/generated/_anint_r10.F90 | 46 +++ libgfortran/generated/_anint_r16.F90 | 46 +++ libgfortran/generated/_anint_r4.F90 | 46 +++ libgfortran/generated/_anint_r8.F90 | 46 +++ libgfortran/generated/_asin_r10.F90 | 46 +++ libgfortran/generated/_asin_r16.F90 | 46 +++ libgfortran/generated/_asin_r4.F90 | 46 +++ libgfortran/generated/_asin_r8.F90 | 46 +++ libgfortran/generated/_asinh_r10.F90 | 46 +++ libgfortran/generated/_asinh_r16.F90 | 46 +++ libgfortran/generated/_asinh_r4.F90 | 46 +++ libgfortran/generated/_asinh_r8.F90 | 46 +++ libgfortran/generated/_atan2_r10.F90 | 46 +++ libgfortran/generated/_atan2_r16.F90 | 46 +++ libgfortran/generated/_atan2_r4.F90 | 46 +++ libgfortran/generated/_atan2_r8.F90 | 46 +++ libgfortran/generated/_atan_r10.F90 | 46 +++ libgfortran/generated/_atan_r16.F90 | 46 +++ libgfortran/generated/_atan_r4.F90 | 46 +++ libgfortran/generated/_atan_r8.F90 | 46 +++ libgfortran/generated/_atanh_r10.F90 | 46 +++ libgfortran/generated/_atanh_r16.F90 | 46 +++ libgfortran/generated/_atanh_r4.F90 | 46 +++ libgfortran/generated/_atanh_r8.F90 | 46 +++ libgfortran/generated/_conjg_c10.F90 | 46 +++ libgfortran/generated/_conjg_c16.F90 | 46 +++ libgfortran/generated/_conjg_c4.F90 | 46 +++ libgfortran/generated/_conjg_c8.F90 | 46 +++ libgfortran/generated/_cos_c10.F90 | 46 +++ libgfortran/generated/_cos_c16.F90 | 46 +++ libgfortran/generated/_cos_c4.F90 | 46 +++ libgfortran/generated/_cos_c8.F90 | 46 +++ libgfortran/generated/_cos_r10.F90 | 46 +++ libgfortran/generated/_cos_r16.F90 | 46 +++ libgfortran/generated/_cos_r4.F90 | 46 +++ libgfortran/generated/_cos_r8.F90 | 46 +++ libgfortran/generated/_cosh_r10.F90 | 46 +++ libgfortran/generated/_cosh_r16.F90 | 46 +++ libgfortran/generated/_cosh_r4.F90 | 46 +++ libgfortran/generated/_cosh_r8.F90 | 46 +++ libgfortran/generated/_dim_i16.F90 | 46 +++ libgfortran/generated/_dim_i4.F90 | 46 +++ libgfortran/generated/_dim_i8.F90 | 46 +++ libgfortran/generated/_dim_r10.F90 | 46 +++ libgfortran/generated/_dim_r16.F90 | 46 +++ libgfortran/generated/_dim_r4.F90 | 46 +++ libgfortran/generated/_dim_r8.F90 | 46 +++ libgfortran/generated/_exp_c10.F90 | 46 +++ libgfortran/generated/_exp_c16.F90 | 46 +++ libgfortran/generated/_exp_c4.F90 | 46 +++ libgfortran/generated/_exp_c8.F90 | 46 +++ libgfortran/generated/_exp_r10.F90 | 46 +++ libgfortran/generated/_exp_r16.F90 | 46 +++ libgfortran/generated/_exp_r4.F90 | 46 +++ libgfortran/generated/_exp_r8.F90 | 46 +++ libgfortran/generated/_log10_r10.F90 | 46 +++ libgfortran/generated/_log10_r16.F90 | 46 +++ libgfortran/generated/_log10_r4.F90 | 46 +++ libgfortran/generated/_log10_r8.F90 | 46 +++ libgfortran/generated/_log_c10.F90 | 46 +++ libgfortran/generated/_log_c16.F90 | 46 +++ libgfortran/generated/_log_c4.F90 | 46 +++ libgfortran/generated/_log_c8.F90 | 46 +++ libgfortran/generated/_log_r10.F90 | 46 +++ libgfortran/generated/_log_r16.F90 | 46 +++ libgfortran/generated/_log_r4.F90 | 46 +++ libgfortran/generated/_log_r8.F90 | 46 +++ libgfortran/generated/_mod_i16.F90 | 46 +++ libgfortran/generated/_mod_i4.F90 | 46 +++ libgfortran/generated/_mod_i8.F90 | 46 +++ libgfortran/generated/_mod_r10.F90 | 46 +++ libgfortran/generated/_mod_r16.F90 | 46 +++ libgfortran/generated/_mod_r4.F90 | 46 +++ libgfortran/generated/_mod_r8.F90 | 46 +++ libgfortran/generated/_sign_i16.F90 | 46 +++ libgfortran/generated/_sign_i4.F90 | 46 +++ libgfortran/generated/_sign_i8.F90 | 46 +++ libgfortran/generated/_sign_r10.F90 | 46 +++ libgfortran/generated/_sign_r16.F90 | 46 +++ libgfortran/generated/_sign_r4.F90 | 46 +++ libgfortran/generated/_sign_r8.F90 | 46 +++ libgfortran/generated/_sin_c10.F90 | 46 +++ libgfortran/generated/_sin_c16.F90 | 46 +++ libgfortran/generated/_sin_c4.F90 | 46 +++ libgfortran/generated/_sin_c8.F90 | 46 +++ libgfortran/generated/_sin_r10.F90 | 46 +++ libgfortran/generated/_sin_r16.F90 | 46 +++ libgfortran/generated/_sin_r4.F90 | 46 +++ libgfortran/generated/_sin_r8.F90 | 46 +++ libgfortran/generated/_sinh_r10.F90 | 46 +++ libgfortran/generated/_sinh_r16.F90 | 46 +++ libgfortran/generated/_sinh_r4.F90 | 46 +++ libgfortran/generated/_sinh_r8.F90 | 46 +++ libgfortran/generated/_sqrt_c10.F90 | 46 +++ libgfortran/generated/_sqrt_c16.F90 | 46 +++ libgfortran/generated/_sqrt_c4.F90 | 46 +++ libgfortran/generated/_sqrt_c8.F90 | 46 +++ libgfortran/generated/_sqrt_r10.F90 | 46 +++ libgfortran/generated/_sqrt_r16.F90 | 46 +++ libgfortran/generated/_sqrt_r4.F90 | 46 +++ libgfortran/generated/_sqrt_r8.F90 | 46 +++ libgfortran/generated/_tan_r10.F90 | 46 +++ libgfortran/generated/_tan_r16.F90 | 46 +++ libgfortran/generated/_tan_r4.F90 | 46 +++ libgfortran/generated/_tan_r8.F90 | 46 +++ libgfortran/generated/_tanh_r10.F90 | 46 +++ libgfortran/generated/_tanh_r16.F90 | 46 +++ libgfortran/generated/_tanh_r4.F90 | 46 +++ libgfortran/generated/_tanh_r8.F90 | 46 +++ libgfortran/generated/all_l1.c | 221 ++++++++++++ libgfortran/generated/all_l16.c | 221 ++++++++++++ libgfortran/generated/all_l2.c | 221 ++++++++++++ libgfortran/generated/all_l4.c | 221 ++++++++++++ libgfortran/generated/all_l8.c | 221 ++++++++++++ libgfortran/generated/any_l1.c | 221 ++++++++++++ libgfortran/generated/any_l16.c | 221 ++++++++++++ libgfortran/generated/any_l2.c | 221 ++++++++++++ libgfortran/generated/any_l4.c | 221 ++++++++++++ libgfortran/generated/any_l8.c | 221 ++++++++++++ libgfortran/generated/bessel_r10.c | 187 ++++++++++ libgfortran/generated/bessel_r16.c | 195 +++++++++++ libgfortran/generated/bessel_r4.c | 187 ++++++++++ libgfortran/generated/bessel_r8.c | 187 ++++++++++ libgfortran/generated/count_16_l.c | 217 ++++++++++++ libgfortran/generated/count_1_l.c | 217 ++++++++++++ libgfortran/generated/count_2_l.c | 217 ++++++++++++ libgfortran/generated/count_4_l.c | 217 ++++++++++++ libgfortran/generated/count_8_l.c | 217 ++++++++++++ libgfortran/generated/cshift0_c10.c | 171 ++++++++++ libgfortran/generated/cshift0_c16.c | 171 ++++++++++ libgfortran/generated/cshift0_c4.c | 171 ++++++++++ libgfortran/generated/cshift0_c8.c | 171 ++++++++++ libgfortran/generated/cshift0_i1.c | 171 ++++++++++ libgfortran/generated/cshift0_i16.c | 171 ++++++++++ libgfortran/generated/cshift0_i2.c | 171 ++++++++++ libgfortran/generated/cshift0_i4.c | 171 ++++++++++ libgfortran/generated/cshift0_i8.c | 171 ++++++++++ libgfortran/generated/cshift0_r10.c | 171 ++++++++++ libgfortran/generated/cshift0_r16.c | 171 ++++++++++ libgfortran/generated/cshift0_r4.c | 171 ++++++++++ libgfortran/generated/cshift0_r8.c | 171 ++++++++++ libgfortran/generated/cshift1_16.c | 273 +++++++++++++++ libgfortran/generated/cshift1_4.c | 273 +++++++++++++++ libgfortran/generated/cshift1_8.c | 273 +++++++++++++++ libgfortran/generated/eoshift1_16.c | 318 +++++++++++++++++ libgfortran/generated/eoshift1_4.c | 318 +++++++++++++++++ libgfortran/generated/eoshift1_8.c | 318 +++++++++++++++++ libgfortran/generated/eoshift3_16.c | 336 ++++++++++++++++++ libgfortran/generated/eoshift3_4.c | 336 ++++++++++++++++++ libgfortran/generated/eoshift3_8.c | 336 ++++++++++++++++++ libgfortran/generated/exponent_r10.c | 45 +++ libgfortran/generated/exponent_r16.c | 49 +++ libgfortran/generated/exponent_r4.c | 45 +++ libgfortran/generated/exponent_r8.c | 45 +++ libgfortran/generated/fraction_r10.c | 44 +++ libgfortran/generated/fraction_r16.c | 48 +++ libgfortran/generated/fraction_r4.c | 44 +++ libgfortran/generated/fraction_r8.c | 44 +++ libgfortran/generated/iall_i1.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iall_i16.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iall_i2.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iall_i4.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iall_i8.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iany_i1.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iany_i16.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iany_i2.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iany_i4.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iany_i8.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/in_pack_c10.c | 119 +++++++ libgfortran/generated/in_pack_c16.c | 119 +++++++ libgfortran/generated/in_pack_c4.c | 119 +++++++ libgfortran/generated/in_pack_c8.c | 119 +++++++ libgfortran/generated/in_pack_i1.c | 119 +++++++ libgfortran/generated/in_pack_i16.c | 119 +++++++ libgfortran/generated/in_pack_i2.c | 119 +++++++ libgfortran/generated/in_pack_i4.c | 119 +++++++ libgfortran/generated/in_pack_i8.c | 119 +++++++ libgfortran/generated/in_pack_r10.c | 119 +++++++ libgfortran/generated/in_pack_r16.c | 119 +++++++ libgfortran/generated/in_pack_r4.c | 119 +++++++ libgfortran/generated/in_pack_r8.c | 119 +++++++ libgfortran/generated/in_unpack_c10.c | 107 ++++++ libgfortran/generated/in_unpack_c16.c | 107 ++++++ libgfortran/generated/in_unpack_c4.c | 107 ++++++ libgfortran/generated/in_unpack_c8.c | 107 ++++++ libgfortran/generated/in_unpack_i1.c | 107 ++++++ libgfortran/generated/in_unpack_i16.c | 107 ++++++ libgfortran/generated/in_unpack_i2.c | 107 ++++++ libgfortran/generated/in_unpack_i4.c | 107 ++++++ libgfortran/generated/in_unpack_i8.c | 107 ++++++ libgfortran/generated/in_unpack_r10.c | 107 ++++++ libgfortran/generated/in_unpack_r16.c | 107 ++++++ libgfortran/generated/in_unpack_r4.c | 107 ++++++ libgfortran/generated/in_unpack_r8.c | 107 ++++++ libgfortran/generated/iparity_i1.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iparity_i16.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iparity_i2.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iparity_i4.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/iparity_i8.c | 509 ++++++++++++++++++++++++++++ libgfortran/generated/matmul_c10.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_c16.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_c4.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_c8.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_i1.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_i16.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_i2.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_i4.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_i8.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_l16.c | 239 +++++++++++++ libgfortran/generated/matmul_l4.c | 239 +++++++++++++ libgfortran/generated/matmul_l8.c | 239 +++++++++++++ libgfortran/generated/matmul_r10.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_r16.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_r4.c | 376 +++++++++++++++++++++ libgfortran/generated/matmul_r8.c | 376 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_i1.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_i16.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_i2.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_i4.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_i8.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_r10.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_r16.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_r4.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_16_r8.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_i1.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_i16.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_i2.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_i4.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_i8.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_r10.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_r16.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_r4.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_4_r8.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_i1.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_i16.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_i2.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_i4.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_i8.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_r10.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_r16.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_r4.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc0_8_r8.c | 383 +++++++++++++++++++++ libgfortran/generated/maxloc1_16_i1.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_16_i16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_16_i2.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_16_i4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_16_i8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_16_r10.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_16_r16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_16_r4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_16_r8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_i1.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_i16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_i2.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_i4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_i8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_r10.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_r16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_r4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_4_r8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_i1.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_i16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_i2.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_i4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_i8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_r10.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_r16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_r4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxloc1_8_r8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/maxval_i1.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/maxval_i16.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/maxval_i2.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/maxval_i4.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/maxval_i8.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/maxval_r10.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/maxval_r16.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/maxval_r4.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/maxval_r8.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minloc0_16_i1.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_16_i16.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_16_i2.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_16_i4.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_16_i8.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_16_r10.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_16_r16.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_16_r4.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_16_r8.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_i1.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_i16.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_i2.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_i4.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_i8.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_r10.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_r16.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_r4.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_4_r8.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_i1.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_i16.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_i2.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_i4.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_i8.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_r10.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_r16.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_r4.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc0_8_r8.c | 383 +++++++++++++++++++++ libgfortran/generated/minloc1_16_i1.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_16_i16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_16_i2.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_16_i4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_16_i8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_16_r10.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_16_r16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_16_r4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_16_r8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_i1.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_i16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_i2.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_i4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_i8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_r10.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_r16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_r4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_4_r8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_i1.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_i16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_i2.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_i4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_i8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_r10.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_r16.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_r4.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minloc1_8_r8.c | 563 +++++++++++++++++++++++++++++++ libgfortran/generated/minval_i1.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minval_i16.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minval_i2.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minval_i4.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minval_i8.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minval_r10.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minval_r16.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minval_r4.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/minval_r8.c | 550 ++++++++++++++++++++++++++++++ libgfortran/generated/misc_specifics.F90 | 206 +++++++++++ libgfortran/generated/nearest_r10.c | 51 +++ libgfortran/generated/nearest_r16.c | 55 +++ libgfortran/generated/nearest_r4.c | 51 +++ libgfortran/generated/nearest_r8.c | 51 +++ libgfortran/generated/norm2_r10.c | 212 ++++++++++++ libgfortran/generated/norm2_r16.c | 220 ++++++++++++ libgfortran/generated/norm2_r4.c | 212 ++++++++++++ libgfortran/generated/norm2_r8.c | 212 ++++++++++++ libgfortran/generated/pack_c10.c | 261 ++++++++++++++ libgfortran/generated/pack_c16.c | 261 ++++++++++++++ libgfortran/generated/pack_c4.c | 261 ++++++++++++++ libgfortran/generated/pack_c8.c | 261 ++++++++++++++ libgfortran/generated/pack_i1.c | 261 ++++++++++++++ libgfortran/generated/pack_i16.c | 261 ++++++++++++++ libgfortran/generated/pack_i2.c | 261 ++++++++++++++ libgfortran/generated/pack_i4.c | 261 ++++++++++++++ libgfortran/generated/pack_i8.c | 261 ++++++++++++++ libgfortran/generated/pack_r10.c | 261 ++++++++++++++ libgfortran/generated/pack_r16.c | 261 ++++++++++++++ libgfortran/generated/pack_r4.c | 261 ++++++++++++++ libgfortran/generated/pack_r8.c | 261 ++++++++++++++ libgfortran/generated/parity_l1.c | 191 +++++++++++ libgfortran/generated/parity_l16.c | 191 +++++++++++ libgfortran/generated/parity_l2.c | 191 +++++++++++ libgfortran/generated/parity_l4.c | 191 +++++++++++ libgfortran/generated/parity_l8.c | 191 +++++++++++ libgfortran/generated/pow_c10_i16.c | 75 ++++ libgfortran/generated/pow_c10_i4.c | 75 ++++ libgfortran/generated/pow_c10_i8.c | 75 ++++ libgfortran/generated/pow_c16_i16.c | 75 ++++ libgfortran/generated/pow_c16_i4.c | 75 ++++ libgfortran/generated/pow_c16_i8.c | 75 ++++ libgfortran/generated/pow_c4_i16.c | 75 ++++ libgfortran/generated/pow_c4_i4.c | 75 ++++ libgfortran/generated/pow_c4_i8.c | 75 ++++ libgfortran/generated/pow_c8_i16.c | 75 ++++ libgfortran/generated/pow_c8_i4.c | 75 ++++ libgfortran/generated/pow_c8_i8.c | 75 ++++ libgfortran/generated/pow_i16_i16.c | 77 +++++ libgfortran/generated/pow_i16_i4.c | 77 +++++ libgfortran/generated/pow_i16_i8.c | 77 +++++ libgfortran/generated/pow_i4_i16.c | 77 +++++ libgfortran/generated/pow_i4_i4.c | 77 +++++ libgfortran/generated/pow_i4_i8.c | 77 +++++ libgfortran/generated/pow_i8_i16.c | 77 +++++ libgfortran/generated/pow_i8_i4.c | 77 +++++ libgfortran/generated/pow_i8_i8.c | 77 +++++ libgfortran/generated/pow_r10_i16.c | 75 ++++ libgfortran/generated/pow_r10_i8.c | 75 ++++ libgfortran/generated/pow_r16_i16.c | 75 ++++ libgfortran/generated/pow_r16_i4.c | 75 ++++ libgfortran/generated/pow_r16_i8.c | 75 ++++ libgfortran/generated/pow_r4_i16.c | 75 ++++ libgfortran/generated/pow_r4_i8.c | 75 ++++ libgfortran/generated/pow_r8_i16.c | 75 ++++ libgfortran/generated/pow_r8_i8.c | 75 ++++ libgfortran/generated/product_c10.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_c16.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_c4.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_c8.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_i1.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_i16.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_i2.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_i4.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_i8.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_r10.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_r16.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_r4.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/product_r8.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/reshape_c10.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_c16.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_c4.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_c8.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_i16.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_i4.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_i8.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_r10.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_r16.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_r4.c | 352 +++++++++++++++++++ libgfortran/generated/reshape_r8.c | 352 +++++++++++++++++++ libgfortran/generated/rrspacing_r10.c | 54 +++ libgfortran/generated/rrspacing_r16.c | 58 ++++ libgfortran/generated/rrspacing_r4.c | 54 +++ libgfortran/generated/rrspacing_r8.c | 54 +++ libgfortran/generated/set_exponent_r10.c | 44 +++ libgfortran/generated/set_exponent_r16.c | 48 +++ libgfortran/generated/set_exponent_r4.c | 44 +++ libgfortran/generated/set_exponent_r8.c | 44 +++ libgfortran/generated/shape_i16.c | 67 ++++ libgfortran/generated/shape_i4.c | 67 ++++ libgfortran/generated/shape_i8.c | 67 ++++ libgfortran/generated/spacing_r10.c | 53 +++ libgfortran/generated/spacing_r16.c | 57 ++++ libgfortran/generated/spacing_r4.c | 53 +++ libgfortran/generated/spacing_r8.c | 53 +++ libgfortran/generated/spread_c10.c | 271 +++++++++++++++ libgfortran/generated/spread_c16.c | 271 +++++++++++++++ libgfortran/generated/spread_c4.c | 271 +++++++++++++++ libgfortran/generated/spread_c8.c | 271 +++++++++++++++ libgfortran/generated/spread_i1.c | 271 +++++++++++++++ libgfortran/generated/spread_i16.c | 271 +++++++++++++++ libgfortran/generated/spread_i2.c | 271 +++++++++++++++ libgfortran/generated/spread_i4.c | 271 +++++++++++++++ libgfortran/generated/spread_i8.c | 271 +++++++++++++++ libgfortran/generated/spread_r10.c | 271 +++++++++++++++ libgfortran/generated/spread_r16.c | 271 +++++++++++++++ libgfortran/generated/spread_r4.c | 271 +++++++++++++++ libgfortran/generated/spread_r8.c | 271 +++++++++++++++ libgfortran/generated/sum_c10.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_c16.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_c4.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_c8.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_i1.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_i16.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_i2.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_i4.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_i8.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_r10.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_r16.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_r4.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/sum_r8.c | 508 ++++++++++++++++++++++++++++ libgfortran/generated/transpose_c10.c | 114 +++++++ libgfortran/generated/transpose_c16.c | 114 +++++++ libgfortran/generated/transpose_c4.c | 114 +++++++ libgfortran/generated/transpose_c8.c | 114 +++++++ libgfortran/generated/transpose_i16.c | 114 +++++++ libgfortran/generated/transpose_i4.c | 114 +++++++ libgfortran/generated/transpose_i8.c | 114 +++++++ libgfortran/generated/transpose_r10.c | 114 +++++++ libgfortran/generated/transpose_r16.c | 114 +++++++ libgfortran/generated/transpose_r4.c | 114 +++++++ libgfortran/generated/transpose_r8.c | 114 +++++++ libgfortran/generated/unpack_c10.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_c16.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_c4.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_c8.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_i1.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_i16.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_i2.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_i4.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_i8.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_r10.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_r16.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_r4.c | 331 ++++++++++++++++++ libgfortran/generated/unpack_r8.c | 331 ++++++++++++++++++ 514 files changed, 127700 insertions(+) create mode 100644 libgfortran/generated/_abs_c10.F90 create mode 100644 libgfortran/generated/_abs_c16.F90 create mode 100644 libgfortran/generated/_abs_c4.F90 create mode 100644 libgfortran/generated/_abs_c8.F90 create mode 100644 libgfortran/generated/_abs_i16.F90 create mode 100644 libgfortran/generated/_abs_i4.F90 create mode 100644 libgfortran/generated/_abs_i8.F90 create mode 100644 libgfortran/generated/_abs_r10.F90 create mode 100644 libgfortran/generated/_abs_r16.F90 create mode 100644 libgfortran/generated/_abs_r4.F90 create mode 100644 libgfortran/generated/_abs_r8.F90 create mode 100644 libgfortran/generated/_acos_r10.F90 create mode 100644 libgfortran/generated/_acos_r16.F90 create mode 100644 libgfortran/generated/_acos_r4.F90 create mode 100644 libgfortran/generated/_acos_r8.F90 create mode 100644 libgfortran/generated/_acosh_r10.F90 create mode 100644 libgfortran/generated/_acosh_r16.F90 create mode 100644 libgfortran/generated/_acosh_r4.F90 create mode 100644 libgfortran/generated/_acosh_r8.F90 create mode 100644 libgfortran/generated/_aimag_c10.F90 create mode 100644 libgfortran/generated/_aimag_c16.F90 create mode 100644 libgfortran/generated/_aimag_c4.F90 create mode 100644 libgfortran/generated/_aimag_c8.F90 create mode 100644 libgfortran/generated/_aint_r10.F90 create mode 100644 libgfortran/generated/_aint_r16.F90 create mode 100644 libgfortran/generated/_aint_r4.F90 create mode 100644 libgfortran/generated/_aint_r8.F90 create mode 100644 libgfortran/generated/_anint_r10.F90 create mode 100644 libgfortran/generated/_anint_r16.F90 create mode 100644 libgfortran/generated/_anint_r4.F90 create mode 100644 libgfortran/generated/_anint_r8.F90 create mode 100644 libgfortran/generated/_asin_r10.F90 create mode 100644 libgfortran/generated/_asin_r16.F90 create mode 100644 libgfortran/generated/_asin_r4.F90 create mode 100644 libgfortran/generated/_asin_r8.F90 create mode 100644 libgfortran/generated/_asinh_r10.F90 create mode 100644 libgfortran/generated/_asinh_r16.F90 create mode 100644 libgfortran/generated/_asinh_r4.F90 create mode 100644 libgfortran/generated/_asinh_r8.F90 create mode 100644 libgfortran/generated/_atan2_r10.F90 create mode 100644 libgfortran/generated/_atan2_r16.F90 create mode 100644 libgfortran/generated/_atan2_r4.F90 create mode 100644 libgfortran/generated/_atan2_r8.F90 create mode 100644 libgfortran/generated/_atan_r10.F90 create mode 100644 libgfortran/generated/_atan_r16.F90 create mode 100644 libgfortran/generated/_atan_r4.F90 create mode 100644 libgfortran/generated/_atan_r8.F90 create mode 100644 libgfortran/generated/_atanh_r10.F90 create mode 100644 libgfortran/generated/_atanh_r16.F90 create mode 100644 libgfortran/generated/_atanh_r4.F90 create mode 100644 libgfortran/generated/_atanh_r8.F90 create mode 100644 libgfortran/generated/_conjg_c10.F90 create mode 100644 libgfortran/generated/_conjg_c16.F90 create mode 100644 libgfortran/generated/_conjg_c4.F90 create mode 100644 libgfortran/generated/_conjg_c8.F90 create mode 100644 libgfortran/generated/_cos_c10.F90 create mode 100644 libgfortran/generated/_cos_c16.F90 create mode 100644 libgfortran/generated/_cos_c4.F90 create mode 100644 libgfortran/generated/_cos_c8.F90 create mode 100644 libgfortran/generated/_cos_r10.F90 create mode 100644 libgfortran/generated/_cos_r16.F90 create mode 100644 libgfortran/generated/_cos_r4.F90 create mode 100644 libgfortran/generated/_cos_r8.F90 create mode 100644 libgfortran/generated/_cosh_r10.F90 create mode 100644 libgfortran/generated/_cosh_r16.F90 create mode 100644 libgfortran/generated/_cosh_r4.F90 create mode 100644 libgfortran/generated/_cosh_r8.F90 create mode 100644 libgfortran/generated/_dim_i16.F90 create mode 100644 libgfortran/generated/_dim_i4.F90 create mode 100644 libgfortran/generated/_dim_i8.F90 create mode 100644 libgfortran/generated/_dim_r10.F90 create mode 100644 libgfortran/generated/_dim_r16.F90 create mode 100644 libgfortran/generated/_dim_r4.F90 create mode 100644 libgfortran/generated/_dim_r8.F90 create mode 100644 libgfortran/generated/_exp_c10.F90 create mode 100644 libgfortran/generated/_exp_c16.F90 create mode 100644 libgfortran/generated/_exp_c4.F90 create mode 100644 libgfortran/generated/_exp_c8.F90 create mode 100644 libgfortran/generated/_exp_r10.F90 create mode 100644 libgfortran/generated/_exp_r16.F90 create mode 100644 libgfortran/generated/_exp_r4.F90 create mode 100644 libgfortran/generated/_exp_r8.F90 create mode 100644 libgfortran/generated/_log10_r10.F90 create mode 100644 libgfortran/generated/_log10_r16.F90 create mode 100644 libgfortran/generated/_log10_r4.F90 create mode 100644 libgfortran/generated/_log10_r8.F90 create mode 100644 libgfortran/generated/_log_c10.F90 create mode 100644 libgfortran/generated/_log_c16.F90 create mode 100644 libgfortran/generated/_log_c4.F90 create mode 100644 libgfortran/generated/_log_c8.F90 create mode 100644 libgfortran/generated/_log_r10.F90 create mode 100644 libgfortran/generated/_log_r16.F90 create mode 100644 libgfortran/generated/_log_r4.F90 create mode 100644 libgfortran/generated/_log_r8.F90 create mode 100644 libgfortran/generated/_mod_i16.F90 create mode 100644 libgfortran/generated/_mod_i4.F90 create mode 100644 libgfortran/generated/_mod_i8.F90 create mode 100644 libgfortran/generated/_mod_r10.F90 create mode 100644 libgfortran/generated/_mod_r16.F90 create mode 100644 libgfortran/generated/_mod_r4.F90 create mode 100644 libgfortran/generated/_mod_r8.F90 create mode 100644 libgfortran/generated/_sign_i16.F90 create mode 100644 libgfortran/generated/_sign_i4.F90 create mode 100644 libgfortran/generated/_sign_i8.F90 create mode 100644 libgfortran/generated/_sign_r10.F90 create mode 100644 libgfortran/generated/_sign_r16.F90 create mode 100644 libgfortran/generated/_sign_r4.F90 create mode 100644 libgfortran/generated/_sign_r8.F90 create mode 100644 libgfortran/generated/_sin_c10.F90 create mode 100644 libgfortran/generated/_sin_c16.F90 create mode 100644 libgfortran/generated/_sin_c4.F90 create mode 100644 libgfortran/generated/_sin_c8.F90 create mode 100644 libgfortran/generated/_sin_r10.F90 create mode 100644 libgfortran/generated/_sin_r16.F90 create mode 100644 libgfortran/generated/_sin_r4.F90 create mode 100644 libgfortran/generated/_sin_r8.F90 create mode 100644 libgfortran/generated/_sinh_r10.F90 create mode 100644 libgfortran/generated/_sinh_r16.F90 create mode 100644 libgfortran/generated/_sinh_r4.F90 create mode 100644 libgfortran/generated/_sinh_r8.F90 create mode 100644 libgfortran/generated/_sqrt_c10.F90 create mode 100644 libgfortran/generated/_sqrt_c16.F90 create mode 100644 libgfortran/generated/_sqrt_c4.F90 create mode 100644 libgfortran/generated/_sqrt_c8.F90 create mode 100644 libgfortran/generated/_sqrt_r10.F90 create mode 100644 libgfortran/generated/_sqrt_r16.F90 create mode 100644 libgfortran/generated/_sqrt_r4.F90 create mode 100644 libgfortran/generated/_sqrt_r8.F90 create mode 100644 libgfortran/generated/_tan_r10.F90 create mode 100644 libgfortran/generated/_tan_r16.F90 create mode 100644 libgfortran/generated/_tan_r4.F90 create mode 100644 libgfortran/generated/_tan_r8.F90 create mode 100644 libgfortran/generated/_tanh_r10.F90 create mode 100644 libgfortran/generated/_tanh_r16.F90 create mode 100644 libgfortran/generated/_tanh_r4.F90 create mode 100644 libgfortran/generated/_tanh_r8.F90 create mode 100644 libgfortran/generated/all_l1.c create mode 100644 libgfortran/generated/all_l16.c create mode 100644 libgfortran/generated/all_l2.c create mode 100644 libgfortran/generated/all_l4.c create mode 100644 libgfortran/generated/all_l8.c create mode 100644 libgfortran/generated/any_l1.c create mode 100644 libgfortran/generated/any_l16.c create mode 100644 libgfortran/generated/any_l2.c create mode 100644 libgfortran/generated/any_l4.c create mode 100644 libgfortran/generated/any_l8.c create mode 100644 libgfortran/generated/bessel_r10.c create mode 100644 libgfortran/generated/bessel_r16.c create mode 100644 libgfortran/generated/bessel_r4.c create mode 100644 libgfortran/generated/bessel_r8.c create mode 100644 libgfortran/generated/count_16_l.c create mode 100644 libgfortran/generated/count_1_l.c create mode 100644 libgfortran/generated/count_2_l.c create mode 100644 libgfortran/generated/count_4_l.c create mode 100644 libgfortran/generated/count_8_l.c create mode 100644 libgfortran/generated/cshift0_c10.c create mode 100644 libgfortran/generated/cshift0_c16.c create mode 100644 libgfortran/generated/cshift0_c4.c create mode 100644 libgfortran/generated/cshift0_c8.c create mode 100644 libgfortran/generated/cshift0_i1.c create mode 100644 libgfortran/generated/cshift0_i16.c create mode 100644 libgfortran/generated/cshift0_i2.c create mode 100644 libgfortran/generated/cshift0_i4.c create mode 100644 libgfortran/generated/cshift0_i8.c create mode 100644 libgfortran/generated/cshift0_r10.c create mode 100644 libgfortran/generated/cshift0_r16.c create mode 100644 libgfortran/generated/cshift0_r4.c create mode 100644 libgfortran/generated/cshift0_r8.c create mode 100644 libgfortran/generated/cshift1_16.c create mode 100644 libgfortran/generated/cshift1_4.c create mode 100644 libgfortran/generated/cshift1_8.c create mode 100644 libgfortran/generated/eoshift1_16.c create mode 100644 libgfortran/generated/eoshift1_4.c create mode 100644 libgfortran/generated/eoshift1_8.c create mode 100644 libgfortran/generated/eoshift3_16.c create mode 100644 libgfortran/generated/eoshift3_4.c create mode 100644 libgfortran/generated/eoshift3_8.c create mode 100644 libgfortran/generated/exponent_r10.c create mode 100644 libgfortran/generated/exponent_r16.c create mode 100644 libgfortran/generated/exponent_r4.c create mode 100644 libgfortran/generated/exponent_r8.c create mode 100644 libgfortran/generated/fraction_r10.c create mode 100644 libgfortran/generated/fraction_r16.c create mode 100644 libgfortran/generated/fraction_r4.c create mode 100644 libgfortran/generated/fraction_r8.c create mode 100644 libgfortran/generated/iall_i1.c create mode 100644 libgfortran/generated/iall_i16.c create mode 100644 libgfortran/generated/iall_i2.c create mode 100644 libgfortran/generated/iall_i4.c create mode 100644 libgfortran/generated/iall_i8.c create mode 100644 libgfortran/generated/iany_i1.c create mode 100644 libgfortran/generated/iany_i16.c create mode 100644 libgfortran/generated/iany_i2.c create mode 100644 libgfortran/generated/iany_i4.c create mode 100644 libgfortran/generated/iany_i8.c create mode 100644 libgfortran/generated/in_pack_c10.c create mode 100644 libgfortran/generated/in_pack_c16.c create mode 100644 libgfortran/generated/in_pack_c4.c create mode 100644 libgfortran/generated/in_pack_c8.c create mode 100644 libgfortran/generated/in_pack_i1.c create mode 100644 libgfortran/generated/in_pack_i16.c create mode 100644 libgfortran/generated/in_pack_i2.c create mode 100644 libgfortran/generated/in_pack_i4.c create mode 100644 libgfortran/generated/in_pack_i8.c create mode 100644 libgfortran/generated/in_pack_r10.c create mode 100644 libgfortran/generated/in_pack_r16.c create mode 100644 libgfortran/generated/in_pack_r4.c create mode 100644 libgfortran/generated/in_pack_r8.c create mode 100644 libgfortran/generated/in_unpack_c10.c create mode 100644 libgfortran/generated/in_unpack_c16.c create mode 100644 libgfortran/generated/in_unpack_c4.c create mode 100644 libgfortran/generated/in_unpack_c8.c create mode 100644 libgfortran/generated/in_unpack_i1.c create mode 100644 libgfortran/generated/in_unpack_i16.c create mode 100644 libgfortran/generated/in_unpack_i2.c create mode 100644 libgfortran/generated/in_unpack_i4.c create mode 100644 libgfortran/generated/in_unpack_i8.c create mode 100644 libgfortran/generated/in_unpack_r10.c create mode 100644 libgfortran/generated/in_unpack_r16.c create mode 100644 libgfortran/generated/in_unpack_r4.c create mode 100644 libgfortran/generated/in_unpack_r8.c create mode 100644 libgfortran/generated/iparity_i1.c create mode 100644 libgfortran/generated/iparity_i16.c create mode 100644 libgfortran/generated/iparity_i2.c create mode 100644 libgfortran/generated/iparity_i4.c create mode 100644 libgfortran/generated/iparity_i8.c create mode 100644 libgfortran/generated/matmul_c10.c create mode 100644 libgfortran/generated/matmul_c16.c create mode 100644 libgfortran/generated/matmul_c4.c create mode 100644 libgfortran/generated/matmul_c8.c create mode 100644 libgfortran/generated/matmul_i1.c create mode 100644 libgfortran/generated/matmul_i16.c create mode 100644 libgfortran/generated/matmul_i2.c create mode 100644 libgfortran/generated/matmul_i4.c create mode 100644 libgfortran/generated/matmul_i8.c create mode 100644 libgfortran/generated/matmul_l16.c create mode 100644 libgfortran/generated/matmul_l4.c create mode 100644 libgfortran/generated/matmul_l8.c create mode 100644 libgfortran/generated/matmul_r10.c create mode 100644 libgfortran/generated/matmul_r16.c create mode 100644 libgfortran/generated/matmul_r4.c create mode 100644 libgfortran/generated/matmul_r8.c create mode 100644 libgfortran/generated/maxloc0_16_i1.c create mode 100644 libgfortran/generated/maxloc0_16_i16.c create mode 100644 libgfortran/generated/maxloc0_16_i2.c create mode 100644 libgfortran/generated/maxloc0_16_i4.c create mode 100644 libgfortran/generated/maxloc0_16_i8.c create mode 100644 libgfortran/generated/maxloc0_16_r10.c create mode 100644 libgfortran/generated/maxloc0_16_r16.c create mode 100644 libgfortran/generated/maxloc0_16_r4.c create mode 100644 libgfortran/generated/maxloc0_16_r8.c create mode 100644 libgfortran/generated/maxloc0_4_i1.c create mode 100644 libgfortran/generated/maxloc0_4_i16.c create mode 100644 libgfortran/generated/maxloc0_4_i2.c create mode 100644 libgfortran/generated/maxloc0_4_i4.c create mode 100644 libgfortran/generated/maxloc0_4_i8.c create mode 100644 libgfortran/generated/maxloc0_4_r10.c create mode 100644 libgfortran/generated/maxloc0_4_r16.c create mode 100644 libgfortran/generated/maxloc0_4_r4.c create mode 100644 libgfortran/generated/maxloc0_4_r8.c create mode 100644 libgfortran/generated/maxloc0_8_i1.c create mode 100644 libgfortran/generated/maxloc0_8_i16.c create mode 100644 libgfortran/generated/maxloc0_8_i2.c create mode 100644 libgfortran/generated/maxloc0_8_i4.c create mode 100644 libgfortran/generated/maxloc0_8_i8.c create mode 100644 libgfortran/generated/maxloc0_8_r10.c create mode 100644 libgfortran/generated/maxloc0_8_r16.c create mode 100644 libgfortran/generated/maxloc0_8_r4.c create mode 100644 libgfortran/generated/maxloc0_8_r8.c create mode 100644 libgfortran/generated/maxloc1_16_i1.c create mode 100644 libgfortran/generated/maxloc1_16_i16.c create mode 100644 libgfortran/generated/maxloc1_16_i2.c create mode 100644 libgfortran/generated/maxloc1_16_i4.c create mode 100644 libgfortran/generated/maxloc1_16_i8.c create mode 100644 libgfortran/generated/maxloc1_16_r10.c create mode 100644 libgfortran/generated/maxloc1_16_r16.c create mode 100644 libgfortran/generated/maxloc1_16_r4.c create mode 100644 libgfortran/generated/maxloc1_16_r8.c create mode 100644 libgfortran/generated/maxloc1_4_i1.c create mode 100644 libgfortran/generated/maxloc1_4_i16.c create mode 100644 libgfortran/generated/maxloc1_4_i2.c create mode 100644 libgfortran/generated/maxloc1_4_i4.c create mode 100644 libgfortran/generated/maxloc1_4_i8.c create mode 100644 libgfortran/generated/maxloc1_4_r10.c create mode 100644 libgfortran/generated/maxloc1_4_r16.c create mode 100644 libgfortran/generated/maxloc1_4_r4.c create mode 100644 libgfortran/generated/maxloc1_4_r8.c create mode 100644 libgfortran/generated/maxloc1_8_i1.c create mode 100644 libgfortran/generated/maxloc1_8_i16.c create mode 100644 libgfortran/generated/maxloc1_8_i2.c create mode 100644 libgfortran/generated/maxloc1_8_i4.c create mode 100644 libgfortran/generated/maxloc1_8_i8.c create mode 100644 libgfortran/generated/maxloc1_8_r10.c create mode 100644 libgfortran/generated/maxloc1_8_r16.c create mode 100644 libgfortran/generated/maxloc1_8_r4.c create mode 100644 libgfortran/generated/maxloc1_8_r8.c create mode 100644 libgfortran/generated/maxval_i1.c create mode 100644 libgfortran/generated/maxval_i16.c create mode 100644 libgfortran/generated/maxval_i2.c create mode 100644 libgfortran/generated/maxval_i4.c create mode 100644 libgfortran/generated/maxval_i8.c create mode 100644 libgfortran/generated/maxval_r10.c create mode 100644 libgfortran/generated/maxval_r16.c create mode 100644 libgfortran/generated/maxval_r4.c create mode 100644 libgfortran/generated/maxval_r8.c create mode 100644 libgfortran/generated/minloc0_16_i1.c create mode 100644 libgfortran/generated/minloc0_16_i16.c create mode 100644 libgfortran/generated/minloc0_16_i2.c create mode 100644 libgfortran/generated/minloc0_16_i4.c create mode 100644 libgfortran/generated/minloc0_16_i8.c create mode 100644 libgfortran/generated/minloc0_16_r10.c create mode 100644 libgfortran/generated/minloc0_16_r16.c create mode 100644 libgfortran/generated/minloc0_16_r4.c create mode 100644 libgfortran/generated/minloc0_16_r8.c create mode 100644 libgfortran/generated/minloc0_4_i1.c create mode 100644 libgfortran/generated/minloc0_4_i16.c create mode 100644 libgfortran/generated/minloc0_4_i2.c create mode 100644 libgfortran/generated/minloc0_4_i4.c create mode 100644 libgfortran/generated/minloc0_4_i8.c create mode 100644 libgfortran/generated/minloc0_4_r10.c create mode 100644 libgfortran/generated/minloc0_4_r16.c create mode 100644 libgfortran/generated/minloc0_4_r4.c create mode 100644 libgfortran/generated/minloc0_4_r8.c create mode 100644 libgfortran/generated/minloc0_8_i1.c create mode 100644 libgfortran/generated/minloc0_8_i16.c create mode 100644 libgfortran/generated/minloc0_8_i2.c create mode 100644 libgfortran/generated/minloc0_8_i4.c create mode 100644 libgfortran/generated/minloc0_8_i8.c create mode 100644 libgfortran/generated/minloc0_8_r10.c create mode 100644 libgfortran/generated/minloc0_8_r16.c create mode 100644 libgfortran/generated/minloc0_8_r4.c create mode 100644 libgfortran/generated/minloc0_8_r8.c create mode 100644 libgfortran/generated/minloc1_16_i1.c create mode 100644 libgfortran/generated/minloc1_16_i16.c create mode 100644 libgfortran/generated/minloc1_16_i2.c create mode 100644 libgfortran/generated/minloc1_16_i4.c create mode 100644 libgfortran/generated/minloc1_16_i8.c create mode 100644 libgfortran/generated/minloc1_16_r10.c create mode 100644 libgfortran/generated/minloc1_16_r16.c create mode 100644 libgfortran/generated/minloc1_16_r4.c create mode 100644 libgfortran/generated/minloc1_16_r8.c create mode 100644 libgfortran/generated/minloc1_4_i1.c create mode 100644 libgfortran/generated/minloc1_4_i16.c create mode 100644 libgfortran/generated/minloc1_4_i2.c create mode 100644 libgfortran/generated/minloc1_4_i4.c create mode 100644 libgfortran/generated/minloc1_4_i8.c create mode 100644 libgfortran/generated/minloc1_4_r10.c create mode 100644 libgfortran/generated/minloc1_4_r16.c create mode 100644 libgfortran/generated/minloc1_4_r4.c create mode 100644 libgfortran/generated/minloc1_4_r8.c create mode 100644 libgfortran/generated/minloc1_8_i1.c create mode 100644 libgfortran/generated/minloc1_8_i16.c create mode 100644 libgfortran/generated/minloc1_8_i2.c create mode 100644 libgfortran/generated/minloc1_8_i4.c create mode 100644 libgfortran/generated/minloc1_8_i8.c create mode 100644 libgfortran/generated/minloc1_8_r10.c create mode 100644 libgfortran/generated/minloc1_8_r16.c create mode 100644 libgfortran/generated/minloc1_8_r4.c create mode 100644 libgfortran/generated/minloc1_8_r8.c create mode 100644 libgfortran/generated/minval_i1.c create mode 100644 libgfortran/generated/minval_i16.c create mode 100644 libgfortran/generated/minval_i2.c create mode 100644 libgfortran/generated/minval_i4.c create mode 100644 libgfortran/generated/minval_i8.c create mode 100644 libgfortran/generated/minval_r10.c create mode 100644 libgfortran/generated/minval_r16.c create mode 100644 libgfortran/generated/minval_r4.c create mode 100644 libgfortran/generated/minval_r8.c create mode 100644 libgfortran/generated/misc_specifics.F90 create mode 100644 libgfortran/generated/nearest_r10.c create mode 100644 libgfortran/generated/nearest_r16.c create mode 100644 libgfortran/generated/nearest_r4.c create mode 100644 libgfortran/generated/nearest_r8.c create mode 100644 libgfortran/generated/norm2_r10.c create mode 100644 libgfortran/generated/norm2_r16.c create mode 100644 libgfortran/generated/norm2_r4.c create mode 100644 libgfortran/generated/norm2_r8.c create mode 100644 libgfortran/generated/pack_c10.c create mode 100644 libgfortran/generated/pack_c16.c create mode 100644 libgfortran/generated/pack_c4.c create mode 100644 libgfortran/generated/pack_c8.c create mode 100644 libgfortran/generated/pack_i1.c create mode 100644 libgfortran/generated/pack_i16.c create mode 100644 libgfortran/generated/pack_i2.c create mode 100644 libgfortran/generated/pack_i4.c create mode 100644 libgfortran/generated/pack_i8.c create mode 100644 libgfortran/generated/pack_r10.c create mode 100644 libgfortran/generated/pack_r16.c create mode 100644 libgfortran/generated/pack_r4.c create mode 100644 libgfortran/generated/pack_r8.c create mode 100644 libgfortran/generated/parity_l1.c create mode 100644 libgfortran/generated/parity_l16.c create mode 100644 libgfortran/generated/parity_l2.c create mode 100644 libgfortran/generated/parity_l4.c create mode 100644 libgfortran/generated/parity_l8.c create mode 100644 libgfortran/generated/pow_c10_i16.c create mode 100644 libgfortran/generated/pow_c10_i4.c create mode 100644 libgfortran/generated/pow_c10_i8.c create mode 100644 libgfortran/generated/pow_c16_i16.c create mode 100644 libgfortran/generated/pow_c16_i4.c create mode 100644 libgfortran/generated/pow_c16_i8.c create mode 100644 libgfortran/generated/pow_c4_i16.c create mode 100644 libgfortran/generated/pow_c4_i4.c create mode 100644 libgfortran/generated/pow_c4_i8.c create mode 100644 libgfortran/generated/pow_c8_i16.c create mode 100644 libgfortran/generated/pow_c8_i4.c create mode 100644 libgfortran/generated/pow_c8_i8.c create mode 100644 libgfortran/generated/pow_i16_i16.c create mode 100644 libgfortran/generated/pow_i16_i4.c create mode 100644 libgfortran/generated/pow_i16_i8.c create mode 100644 libgfortran/generated/pow_i4_i16.c create mode 100644 libgfortran/generated/pow_i4_i4.c create mode 100644 libgfortran/generated/pow_i4_i8.c create mode 100644 libgfortran/generated/pow_i8_i16.c create mode 100644 libgfortran/generated/pow_i8_i4.c create mode 100644 libgfortran/generated/pow_i8_i8.c create mode 100644 libgfortran/generated/pow_r10_i16.c create mode 100644 libgfortran/generated/pow_r10_i8.c create mode 100644 libgfortran/generated/pow_r16_i16.c create mode 100644 libgfortran/generated/pow_r16_i4.c create mode 100644 libgfortran/generated/pow_r16_i8.c create mode 100644 libgfortran/generated/pow_r4_i16.c create mode 100644 libgfortran/generated/pow_r4_i8.c create mode 100644 libgfortran/generated/pow_r8_i16.c create mode 100644 libgfortran/generated/pow_r8_i8.c create mode 100644 libgfortran/generated/product_c10.c create mode 100644 libgfortran/generated/product_c16.c create mode 100644 libgfortran/generated/product_c4.c create mode 100644 libgfortran/generated/product_c8.c create mode 100644 libgfortran/generated/product_i1.c create mode 100644 libgfortran/generated/product_i16.c create mode 100644 libgfortran/generated/product_i2.c create mode 100644 libgfortran/generated/product_i4.c create mode 100644 libgfortran/generated/product_i8.c create mode 100644 libgfortran/generated/product_r10.c create mode 100644 libgfortran/generated/product_r16.c create mode 100644 libgfortran/generated/product_r4.c create mode 100644 libgfortran/generated/product_r8.c create mode 100644 libgfortran/generated/reshape_c10.c create mode 100644 libgfortran/generated/reshape_c16.c create mode 100644 libgfortran/generated/reshape_c4.c create mode 100644 libgfortran/generated/reshape_c8.c create mode 100644 libgfortran/generated/reshape_i16.c create mode 100644 libgfortran/generated/reshape_i4.c create mode 100644 libgfortran/generated/reshape_i8.c create mode 100644 libgfortran/generated/reshape_r10.c create mode 100644 libgfortran/generated/reshape_r16.c create mode 100644 libgfortran/generated/reshape_r4.c create mode 100644 libgfortran/generated/reshape_r8.c create mode 100644 libgfortran/generated/rrspacing_r10.c create mode 100644 libgfortran/generated/rrspacing_r16.c create mode 100644 libgfortran/generated/rrspacing_r4.c create mode 100644 libgfortran/generated/rrspacing_r8.c create mode 100644 libgfortran/generated/set_exponent_r10.c create mode 100644 libgfortran/generated/set_exponent_r16.c create mode 100644 libgfortran/generated/set_exponent_r4.c create mode 100644 libgfortran/generated/set_exponent_r8.c create mode 100644 libgfortran/generated/shape_i16.c create mode 100644 libgfortran/generated/shape_i4.c create mode 100644 libgfortran/generated/shape_i8.c create mode 100644 libgfortran/generated/spacing_r10.c create mode 100644 libgfortran/generated/spacing_r16.c create mode 100644 libgfortran/generated/spacing_r4.c create mode 100644 libgfortran/generated/spacing_r8.c create mode 100644 libgfortran/generated/spread_c10.c create mode 100644 libgfortran/generated/spread_c16.c create mode 100644 libgfortran/generated/spread_c4.c create mode 100644 libgfortran/generated/spread_c8.c create mode 100644 libgfortran/generated/spread_i1.c create mode 100644 libgfortran/generated/spread_i16.c create mode 100644 libgfortran/generated/spread_i2.c create mode 100644 libgfortran/generated/spread_i4.c create mode 100644 libgfortran/generated/spread_i8.c create mode 100644 libgfortran/generated/spread_r10.c create mode 100644 libgfortran/generated/spread_r16.c create mode 100644 libgfortran/generated/spread_r4.c create mode 100644 libgfortran/generated/spread_r8.c create mode 100644 libgfortran/generated/sum_c10.c create mode 100644 libgfortran/generated/sum_c16.c create mode 100644 libgfortran/generated/sum_c4.c create mode 100644 libgfortran/generated/sum_c8.c create mode 100644 libgfortran/generated/sum_i1.c create mode 100644 libgfortran/generated/sum_i16.c create mode 100644 libgfortran/generated/sum_i2.c create mode 100644 libgfortran/generated/sum_i4.c create mode 100644 libgfortran/generated/sum_i8.c create mode 100644 libgfortran/generated/sum_r10.c create mode 100644 libgfortran/generated/sum_r16.c create mode 100644 libgfortran/generated/sum_r4.c create mode 100644 libgfortran/generated/sum_r8.c create mode 100644 libgfortran/generated/transpose_c10.c create mode 100644 libgfortran/generated/transpose_c16.c create mode 100644 libgfortran/generated/transpose_c4.c create mode 100644 libgfortran/generated/transpose_c8.c create mode 100644 libgfortran/generated/transpose_i16.c create mode 100644 libgfortran/generated/transpose_i4.c create mode 100644 libgfortran/generated/transpose_i8.c create mode 100644 libgfortran/generated/transpose_r10.c create mode 100644 libgfortran/generated/transpose_r16.c create mode 100644 libgfortran/generated/transpose_r4.c create mode 100644 libgfortran/generated/transpose_r8.c create mode 100644 libgfortran/generated/unpack_c10.c create mode 100644 libgfortran/generated/unpack_c16.c create mode 100644 libgfortran/generated/unpack_c4.c create mode 100644 libgfortran/generated/unpack_c8.c create mode 100644 libgfortran/generated/unpack_i1.c create mode 100644 libgfortran/generated/unpack_i16.c create mode 100644 libgfortran/generated/unpack_i2.c create mode 100644 libgfortran/generated/unpack_i4.c create mode 100644 libgfortran/generated/unpack_i8.c create mode 100644 libgfortran/generated/unpack_r10.c create mode 100644 libgfortran/generated/unpack_r16.c create mode 100644 libgfortran/generated/unpack_r4.c create mode 100644 libgfortran/generated/unpack_r8.c (limited to 'libgfortran/generated') diff --git a/libgfortran/generated/_abs_c10.F90 b/libgfortran/generated/_abs_c10.F90 new file mode 100644 index 000000000..96938938e --- /dev/null +++ b/libgfortran/generated/_abs_c10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__abs_c10 (parm) + complex (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__abs_c10 + + _gfortran_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 000000000..db5cb0087 --- /dev/null +++ b/libgfortran/generated/_abs_c16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__abs_c16 (parm) + complex (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__abs_c16 + + _gfortran_specific__abs_c16 = abs (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_c4.F90 b/libgfortran/generated/_abs_c4.F90 new file mode 100644 index 000000000..d0cb85be3 --- /dev/null +++ b/libgfortran/generated/_abs_c4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__abs_c4 (parm) + complex (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__abs_c4 + + _gfortran_specific__abs_c4 = abs (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_c8.F90 b/libgfortran/generated/_abs_c8.F90 new file mode 100644 index 000000000..b5a284931 --- /dev/null +++ b/libgfortran/generated/_abs_c8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__abs_c8 (parm) + complex (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__abs_c8 + + _gfortran_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 000000000..d7b825bfa --- /dev/null +++ b/libgfortran/generated/_abs_i16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_16) + + +elemental function _gfortran_specific__abs_i16 (parm) + integer (kind=16), intent (in) :: parm + integer (kind=16) :: _gfortran_specific__abs_i16 + + _gfortran_specific__abs_i16 = abs (parm) +end function + + +#endif diff --git a/libgfortran/generated/_abs_i4.F90 b/libgfortran/generated/_abs_i4.F90 new file mode 100644 index 000000000..3d6619a27 --- /dev/null +++ b/libgfortran/generated/_abs_i4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_4) + + +elemental function _gfortran_specific__abs_i4 (parm) + integer (kind=4), intent (in) :: parm + integer (kind=4) :: _gfortran_specific__abs_i4 + + _gfortran_specific__abs_i4 = abs (parm) +end function + + +#endif diff --git a/libgfortran/generated/_abs_i8.F90 b/libgfortran/generated/_abs_i8.F90 new file mode 100644 index 000000000..9e68ba667 --- /dev/null +++ b/libgfortran/generated/_abs_i8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_8) + + +elemental function _gfortran_specific__abs_i8 (parm) + integer (kind=8), intent (in) :: parm + integer (kind=8) :: _gfortran_specific__abs_i8 + + _gfortran_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 000000000..26b6aa6c7 --- /dev/null +++ b/libgfortran/generated/_abs_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__abs_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__abs_r10 + + _gfortran_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 000000000..3117d4a58 --- /dev/null +++ b/libgfortran/generated/_abs_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__abs_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__abs_r16 + + _gfortran_specific__abs_r16 = abs (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_r4.F90 b/libgfortran/generated/_abs_r4.F90 new file mode 100644 index 000000000..bb4ac4a76 --- /dev/null +++ b/libgfortran/generated/_abs_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__abs_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__abs_r4 + + _gfortran_specific__abs_r4 = abs (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_abs_r8.F90 b/libgfortran/generated/_abs_r8.F90 new file mode 100644 index 000000000..b41e69821 --- /dev/null +++ b/libgfortran/generated/_abs_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__abs_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__abs_r8 + + _gfortran_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 000000000..d5c3cd5a4 --- /dev/null +++ b/libgfortran/generated/_acos_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__acos_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__acos_r10 + + _gfortran_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 000000000..80aa22c8b --- /dev/null +++ b/libgfortran/generated/_acos_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__acos_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__acos_r16 + + _gfortran_specific__acos_r16 = acos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_acos_r4.F90 b/libgfortran/generated/_acos_r4.F90 new file mode 100644 index 000000000..300524ed6 --- /dev/null +++ b/libgfortran/generated/_acos_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__acos_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__acos_r4 + + _gfortran_specific__acos_r4 = acos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_acos_r8.F90 b/libgfortran/generated/_acos_r8.F90 new file mode 100644 index 000000000..ca526cbb0 --- /dev/null +++ b/libgfortran/generated/_acos_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__acos_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__acos_r8 + + _gfortran_specific__acos_r8 = acos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_acosh_r10.F90 b/libgfortran/generated/_acosh_r10.F90 new file mode 100644 index 000000000..f8193f9df --- /dev/null +++ b/libgfortran/generated/_acosh_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_ACOSHL + +elemental function _gfortran_specific__acosh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__acosh_r10 + + _gfortran_specific__acosh_r10 = acosh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_acosh_r16.F90 b/libgfortran/generated/_acosh_r16.F90 new file mode 100644 index 000000000..e2ae3bde8 --- /dev/null +++ b/libgfortran/generated/_acosh_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_ACOSHL + +elemental function _gfortran_specific__acosh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__acosh_r16 + + _gfortran_specific__acosh_r16 = acosh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_acosh_r4.F90 b/libgfortran/generated/_acosh_r4.F90 new file mode 100644 index 000000000..61412c32e --- /dev/null +++ b/libgfortran/generated/_acosh_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_ACOSHF + +elemental function _gfortran_specific__acosh_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__acosh_r4 + + _gfortran_specific__acosh_r4 = acosh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_acosh_r8.F90 b/libgfortran/generated/_acosh_r8.F90 new file mode 100644 index 000000000..cb230aeed --- /dev/null +++ b/libgfortran/generated/_acosh_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_ACOSH + +elemental function _gfortran_specific__acosh_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__acosh_r8 + + _gfortran_specific__acosh_r8 = acosh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_aimag_c10.F90 b/libgfortran/generated/_aimag_c10.F90 new file mode 100644 index 000000000..584299e39 --- /dev/null +++ b/libgfortran/generated/_aimag_c10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) + + +elemental function _gfortran_specific__aimag_c10 (parm) + complex (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__aimag_c10 + + _gfortran_specific__aimag_c10 = aimag (parm) +end function + + +#endif diff --git a/libgfortran/generated/_aimag_c16.F90 b/libgfortran/generated/_aimag_c16.F90 new file mode 100644 index 000000000..01f24a282 --- /dev/null +++ b/libgfortran/generated/_aimag_c16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) + + +elemental function _gfortran_specific__aimag_c16 (parm) + complex (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__aimag_c16 + + _gfortran_specific__aimag_c16 = aimag (parm) +end function + + +#endif diff --git a/libgfortran/generated/_aimag_c4.F90 b/libgfortran/generated/_aimag_c4.F90 new file mode 100644 index 000000000..d52e057cf --- /dev/null +++ b/libgfortran/generated/_aimag_c4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) + + +elemental function _gfortran_specific__aimag_c4 (parm) + complex (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__aimag_c4 + + _gfortran_specific__aimag_c4 = aimag (parm) +end function + + +#endif diff --git a/libgfortran/generated/_aimag_c8.F90 b/libgfortran/generated/_aimag_c8.F90 new file mode 100644 index 000000000..b1a933ffc --- /dev/null +++ b/libgfortran/generated/_aimag_c8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) + + +elemental function _gfortran_specific__aimag_c8 (parm) + complex (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__aimag_c8 + + _gfortran_specific__aimag_c8 = aimag (parm) +end function + + +#endif diff --git a/libgfortran/generated/_aint_r10.F90 b/libgfortran/generated/_aint_r10.F90 new file mode 100644 index 000000000..47a942405 --- /dev/null +++ b/libgfortran/generated/_aint_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__aint_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__aint_r10 + + _gfortran_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 000000000..b91640ee2 --- /dev/null +++ b/libgfortran/generated/_aint_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__aint_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__aint_r16 + + _gfortran_specific__aint_r16 = aint (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_aint_r4.F90 b/libgfortran/generated/_aint_r4.F90 new file mode 100644 index 000000000..7607afdc6 --- /dev/null +++ b/libgfortran/generated/_aint_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__aint_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__aint_r4 + + _gfortran_specific__aint_r4 = aint (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_aint_r8.F90 b/libgfortran/generated/_aint_r8.F90 new file mode 100644 index 000000000..c0b666aa0 --- /dev/null +++ b/libgfortran/generated/_aint_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__aint_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__aint_r8 + + _gfortran_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 000000000..a768642e1 --- /dev/null +++ b/libgfortran/generated/_anint_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__anint_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__anint_r10 + + _gfortran_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 000000000..924b9143c --- /dev/null +++ b/libgfortran/generated/_anint_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__anint_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__anint_r16 + + _gfortran_specific__anint_r16 = anint (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_anint_r4.F90 b/libgfortran/generated/_anint_r4.F90 new file mode 100644 index 000000000..000a20b01 --- /dev/null +++ b/libgfortran/generated/_anint_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__anint_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__anint_r4 + + _gfortran_specific__anint_r4 = anint (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_anint_r8.F90 b/libgfortran/generated/_anint_r8.F90 new file mode 100644 index 000000000..be122bd3f --- /dev/null +++ b/libgfortran/generated/_anint_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__anint_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__anint_r8 + + _gfortran_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 000000000..fe2b68a23 --- /dev/null +++ b/libgfortran/generated/_asin_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__asin_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__asin_r10 + + _gfortran_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 000000000..87bf9e783 --- /dev/null +++ b/libgfortran/generated/_asin_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__asin_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__asin_r16 + + _gfortran_specific__asin_r16 = asin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_asin_r4.F90 b/libgfortran/generated/_asin_r4.F90 new file mode 100644 index 000000000..63367d1e8 --- /dev/null +++ b/libgfortran/generated/_asin_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__asin_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__asin_r4 + + _gfortran_specific__asin_r4 = asin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_asin_r8.F90 b/libgfortran/generated/_asin_r8.F90 new file mode 100644 index 000000000..97e0088bd --- /dev/null +++ b/libgfortran/generated/_asin_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__asin_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__asin_r8 + + _gfortran_specific__asin_r8 = asin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_asinh_r10.F90 b/libgfortran/generated/_asinh_r10.F90 new file mode 100644 index 000000000..a05abe78d --- /dev/null +++ b/libgfortran/generated/_asinh_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_ASINHL + +elemental function _gfortran_specific__asinh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__asinh_r10 + + _gfortran_specific__asinh_r10 = asinh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_asinh_r16.F90 b/libgfortran/generated/_asinh_r16.F90 new file mode 100644 index 000000000..e0e94d547 --- /dev/null +++ b/libgfortran/generated/_asinh_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_ASINHL + +elemental function _gfortran_specific__asinh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__asinh_r16 + + _gfortran_specific__asinh_r16 = asinh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_asinh_r4.F90 b/libgfortran/generated/_asinh_r4.F90 new file mode 100644 index 000000000..f80bf5084 --- /dev/null +++ b/libgfortran/generated/_asinh_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_ASINHF + +elemental function _gfortran_specific__asinh_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__asinh_r4 + + _gfortran_specific__asinh_r4 = asinh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_asinh_r8.F90 b/libgfortran/generated/_asinh_r8.F90 new file mode 100644 index 000000000..8b636a65c --- /dev/null +++ b/libgfortran/generated/_asinh_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_ASINH + +elemental function _gfortran_specific__asinh_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__asinh_r8 + + _gfortran_specific__asinh_r8 = asinh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atan2_r10.F90 b/libgfortran/generated/_atan2_r10.F90 new file mode 100644 index 000000000..c38b3c335 --- /dev/null +++ b/libgfortran/generated/_atan2_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__atan2_r10 (p1, p2) + real (kind=10), intent (in) :: p1, p2 + real (kind=10) :: _gfortran_specific__atan2_r10 + + _gfortran_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 000000000..4d65da2a8 --- /dev/null +++ b/libgfortran/generated/_atan2_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__atan2_r16 (p1, p2) + real (kind=16), intent (in) :: p1, p2 + real (kind=16) :: _gfortran_specific__atan2_r16 + + _gfortran_specific__atan2_r16 = atan2 (p1, p2) +end function + +#endif + +#endif diff --git a/libgfortran/generated/_atan2_r4.F90 b/libgfortran/generated/_atan2_r4.F90 new file mode 100644 index 000000000..cdebd47dd --- /dev/null +++ b/libgfortran/generated/_atan2_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__atan2_r4 (p1, p2) + real (kind=4), intent (in) :: p1, p2 + real (kind=4) :: _gfortran_specific__atan2_r4 + + _gfortran_specific__atan2_r4 = atan2 (p1, p2) +end function + +#endif + +#endif diff --git a/libgfortran/generated/_atan2_r8.F90 b/libgfortran/generated/_atan2_r8.F90 new file mode 100644 index 000000000..7cfe47ec7 --- /dev/null +++ b/libgfortran/generated/_atan2_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__atan2_r8 (p1, p2) + real (kind=8), intent (in) :: p1, p2 + real (kind=8) :: _gfortran_specific__atan2_r8 + + _gfortran_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 000000000..36a813b69 --- /dev/null +++ b/libgfortran/generated/_atan_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__atan_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__atan_r10 + + _gfortran_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 000000000..b177eeb19 --- /dev/null +++ b/libgfortran/generated/_atan_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__atan_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__atan_r16 + + _gfortran_specific__atan_r16 = atan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atan_r4.F90 b/libgfortran/generated/_atan_r4.F90 new file mode 100644 index 000000000..0ec9fe64b --- /dev/null +++ b/libgfortran/generated/_atan_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__atan_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__atan_r4 + + _gfortran_specific__atan_r4 = atan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atan_r8.F90 b/libgfortran/generated/_atan_r8.F90 new file mode 100644 index 000000000..df118004a --- /dev/null +++ b/libgfortran/generated/_atan_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__atan_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__atan_r8 + + _gfortran_specific__atan_r8 = atan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atanh_r10.F90 b/libgfortran/generated/_atanh_r10.F90 new file mode 100644 index 000000000..a695cee9a --- /dev/null +++ b/libgfortran/generated/_atanh_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) +#ifdef HAVE_ATANHL + +elemental function _gfortran_specific__atanh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__atanh_r10 + + _gfortran_specific__atanh_r10 = atanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atanh_r16.F90 b/libgfortran/generated/_atanh_r16.F90 new file mode 100644 index 000000000..d7e216c3e --- /dev/null +++ b/libgfortran/generated/_atanh_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) +#ifdef HAVE_ATANHL + +elemental function _gfortran_specific__atanh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__atanh_r16 + + _gfortran_specific__atanh_r16 = atanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atanh_r4.F90 b/libgfortran/generated/_atanh_r4.F90 new file mode 100644 index 000000000..09fc73f5c --- /dev/null +++ b/libgfortran/generated/_atanh_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) +#ifdef HAVE_ATANHF + +elemental function _gfortran_specific__atanh_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__atanh_r4 + + _gfortran_specific__atanh_r4 = atanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_atanh_r8.F90 b/libgfortran/generated/_atanh_r8.F90 new file mode 100644 index 000000000..f78eca062 --- /dev/null +++ b/libgfortran/generated/_atanh_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) +#ifdef HAVE_ATANH + +elemental function _gfortran_specific__atanh_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__atanh_r8 + + _gfortran_specific__atanh_r8 = atanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_conjg_c10.F90 b/libgfortran/generated/_conjg_c10.F90 new file mode 100644 index 000000000..d53ac1e19 --- /dev/null +++ b/libgfortran/generated/_conjg_c10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_10) + + +elemental function _gfortran_specific__conjg_10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: _gfortran_specific__conjg_10 + + _gfortran_specific__conjg_10 = conjg (parm) +end function + + +#endif diff --git a/libgfortran/generated/_conjg_c16.F90 b/libgfortran/generated/_conjg_c16.F90 new file mode 100644 index 000000000..0052f611c --- /dev/null +++ b/libgfortran/generated/_conjg_c16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_16) + + +elemental function _gfortran_specific__conjg_16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: _gfortran_specific__conjg_16 + + _gfortran_specific__conjg_16 = conjg (parm) +end function + + +#endif diff --git a/libgfortran/generated/_conjg_c4.F90 b/libgfortran/generated/_conjg_c4.F90 new file mode 100644 index 000000000..138266eba --- /dev/null +++ b/libgfortran/generated/_conjg_c4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_4) + + +elemental function _gfortran_specific__conjg_4 (parm) + complex (kind=4), intent (in) :: parm + complex (kind=4) :: _gfortran_specific__conjg_4 + + _gfortran_specific__conjg_4 = conjg (parm) +end function + + +#endif diff --git a/libgfortran/generated/_conjg_c8.F90 b/libgfortran/generated/_conjg_c8.F90 new file mode 100644 index 000000000..ed1c8f5e1 --- /dev/null +++ b/libgfortran/generated/_conjg_c8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_COMPLEX_8) + + +elemental function _gfortran_specific__conjg_8 (parm) + complex (kind=8), intent (in) :: parm + complex (kind=8) :: _gfortran_specific__conjg_8 + + _gfortran_specific__conjg_8 = conjg (parm) +end function + + +#endif diff --git a/libgfortran/generated/_cos_c10.F90 b/libgfortran/generated/_cos_c10.F90 new file mode 100644 index 000000000..612d4387e --- /dev/null +++ b/libgfortran/generated/_cos_c10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cos_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: _gfortran_specific__cos_c10 + + _gfortran_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 000000000..7cea76493 --- /dev/null +++ b/libgfortran/generated/_cos_c16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cos_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: _gfortran_specific__cos_c16 + + _gfortran_specific__cos_c16 = cos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_c4.F90 b/libgfortran/generated/_cos_c4.F90 new file mode 100644 index 000000000..f0dd76e8d --- /dev/null +++ b/libgfortran/generated/_cos_c4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cos_c4 (parm) + complex (kind=4), intent (in) :: parm + complex (kind=4) :: _gfortran_specific__cos_c4 + + _gfortran_specific__cos_c4 = cos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_c8.F90 b/libgfortran/generated/_cos_c8.F90 new file mode 100644 index 000000000..7acc35a69 --- /dev/null +++ b/libgfortran/generated/_cos_c8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cos_c8 (parm) + complex (kind=8), intent (in) :: parm + complex (kind=8) :: _gfortran_specific__cos_c8 + + _gfortran_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 000000000..678dccb57 --- /dev/null +++ b/libgfortran/generated/_cos_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cos_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__cos_r10 + + _gfortran_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 000000000..dacd87721 --- /dev/null +++ b/libgfortran/generated/_cos_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cos_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__cos_r16 + + _gfortran_specific__cos_r16 = cos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_r4.F90 b/libgfortran/generated/_cos_r4.F90 new file mode 100644 index 000000000..c6dc39ae3 --- /dev/null +++ b/libgfortran/generated/_cos_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cos_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__cos_r4 + + _gfortran_specific__cos_r4 = cos (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cos_r8.F90 b/libgfortran/generated/_cos_r8.F90 new file mode 100644 index 000000000..51b42cd99 --- /dev/null +++ b/libgfortran/generated/_cos_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cos_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__cos_r8 + + _gfortran_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 000000000..b7826f25e --- /dev/null +++ b/libgfortran/generated/_cosh_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cosh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__cosh_r10 + + _gfortran_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 000000000..adbb56732 --- /dev/null +++ b/libgfortran/generated/_cosh_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cosh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__cosh_r16 + + _gfortran_specific__cosh_r16 = cosh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cosh_r4.F90 b/libgfortran/generated/_cosh_r4.F90 new file mode 100644 index 000000000..98719312e --- /dev/null +++ b/libgfortran/generated/_cosh_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cosh_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__cosh_r4 + + _gfortran_specific__cosh_r4 = cosh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_cosh_r8.F90 b/libgfortran/generated/_cosh_r8.F90 new file mode 100644 index 000000000..4b0362f2e --- /dev/null +++ b/libgfortran/generated/_cosh_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__cosh_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__cosh_r8 + + _gfortran_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 000000000..70753b42f --- /dev/null +++ b/libgfortran/generated/_dim_i16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_16) + + + +elemental function _gfortran_specific__dim_i16 (p1, p2) + integer (kind=16), intent (in) :: p1, p2 + integer (kind=16) :: _gfortran_specific__dim_i16 + + _gfortran_specific__dim_i16 = dim (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_dim_i4.F90 b/libgfortran/generated/_dim_i4.F90 new file mode 100644 index 000000000..c80a367f1 --- /dev/null +++ b/libgfortran/generated/_dim_i4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_4) + + + +elemental function _gfortran_specific__dim_i4 (p1, p2) + integer (kind=4), intent (in) :: p1, p2 + integer (kind=4) :: _gfortran_specific__dim_i4 + + _gfortran_specific__dim_i4 = dim (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_dim_i8.F90 b/libgfortran/generated/_dim_i8.F90 new file mode 100644 index 000000000..cbb45fcf1 --- /dev/null +++ b/libgfortran/generated/_dim_i8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_8) + + + +elemental function _gfortran_specific__dim_i8 (p1, p2) + integer (kind=8), intent (in) :: p1, p2 + integer (kind=8) :: _gfortran_specific__dim_i8 + + _gfortran_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 000000000..e84e1428f --- /dev/null +++ b/libgfortran/generated/_dim_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) + + + +elemental function _gfortran_specific__dim_r10 (p1, p2) + real (kind=10), intent (in) :: p1, p2 + real (kind=10) :: _gfortran_specific__dim_r10 + + _gfortran_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 000000000..6738e735c --- /dev/null +++ b/libgfortran/generated/_dim_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) + + + +elemental function _gfortran_specific__dim_r16 (p1, p2) + real (kind=16), intent (in) :: p1, p2 + real (kind=16) :: _gfortran_specific__dim_r16 + + _gfortran_specific__dim_r16 = dim (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_dim_r4.F90 b/libgfortran/generated/_dim_r4.F90 new file mode 100644 index 000000000..22f5f0092 --- /dev/null +++ b/libgfortran/generated/_dim_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) + + + +elemental function _gfortran_specific__dim_r4 (p1, p2) + real (kind=4), intent (in) :: p1, p2 + real (kind=4) :: _gfortran_specific__dim_r4 + + _gfortran_specific__dim_r4 = dim (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_dim_r8.F90 b/libgfortran/generated/_dim_r8.F90 new file mode 100644 index 000000000..e209b9452 --- /dev/null +++ b/libgfortran/generated/_dim_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) + + + +elemental function _gfortran_specific__dim_r8 (p1, p2) + real (kind=8), intent (in) :: p1, p2 + real (kind=8) :: _gfortran_specific__dim_r8 + + _gfortran_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 000000000..5549cd630 --- /dev/null +++ b/libgfortran/generated/_exp_c10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__exp_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: _gfortran_specific__exp_c10 + + _gfortran_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 000000000..09f4b72a9 --- /dev/null +++ b/libgfortran/generated/_exp_c16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__exp_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: _gfortran_specific__exp_c16 + + _gfortran_specific__exp_c16 = exp (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_c4.F90 b/libgfortran/generated/_exp_c4.F90 new file mode 100644 index 000000000..27c030aae --- /dev/null +++ b/libgfortran/generated/_exp_c4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__exp_c4 (parm) + complex (kind=4), intent (in) :: parm + complex (kind=4) :: _gfortran_specific__exp_c4 + + _gfortran_specific__exp_c4 = exp (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_c8.F90 b/libgfortran/generated/_exp_c8.F90 new file mode 100644 index 000000000..9b03a7120 --- /dev/null +++ b/libgfortran/generated/_exp_c8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__exp_c8 (parm) + complex (kind=8), intent (in) :: parm + complex (kind=8) :: _gfortran_specific__exp_c8 + + _gfortran_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 000000000..c66a1b71a --- /dev/null +++ b/libgfortran/generated/_exp_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__exp_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__exp_r10 + + _gfortran_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 000000000..3c6c02db6 --- /dev/null +++ b/libgfortran/generated/_exp_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__exp_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__exp_r16 + + _gfortran_specific__exp_r16 = exp (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_r4.F90 b/libgfortran/generated/_exp_r4.F90 new file mode 100644 index 000000000..2ed5ee383 --- /dev/null +++ b/libgfortran/generated/_exp_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__exp_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__exp_r4 + + _gfortran_specific__exp_r4 = exp (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_exp_r8.F90 b/libgfortran/generated/_exp_r8.F90 new file mode 100644 index 000000000..64111e0ab --- /dev/null +++ b/libgfortran/generated/_exp_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__exp_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__exp_r8 + + _gfortran_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 000000000..4aa1f9826 --- /dev/null +++ b/libgfortran/generated/_log10_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log10_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__log10_r10 + + _gfortran_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 000000000..0af36baa8 --- /dev/null +++ b/libgfortran/generated/_log10_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log10_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__log10_r16 + + _gfortran_specific__log10_r16 = log10 (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log10_r4.F90 b/libgfortran/generated/_log10_r4.F90 new file mode 100644 index 000000000..d98851fce --- /dev/null +++ b/libgfortran/generated/_log10_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log10_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__log10_r4 + + _gfortran_specific__log10_r4 = log10 (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log10_r8.F90 b/libgfortran/generated/_log10_r8.F90 new file mode 100644 index 000000000..cd687d009 --- /dev/null +++ b/libgfortran/generated/_log10_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log10_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__log10_r8 + + _gfortran_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 000000000..c7524e4ed --- /dev/null +++ b/libgfortran/generated/_log_c10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: _gfortran_specific__log_c10 + + _gfortran_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 000000000..32a8171db --- /dev/null +++ b/libgfortran/generated/_log_c16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: _gfortran_specific__log_c16 + + _gfortran_specific__log_c16 = log (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log_c4.F90 b/libgfortran/generated/_log_c4.F90 new file mode 100644 index 000000000..b57818b51 --- /dev/null +++ b/libgfortran/generated/_log_c4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log_c4 (parm) + complex (kind=4), intent (in) :: parm + complex (kind=4) :: _gfortran_specific__log_c4 + + _gfortran_specific__log_c4 = log (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log_c8.F90 b/libgfortran/generated/_log_c8.F90 new file mode 100644 index 000000000..3572b7d0a --- /dev/null +++ b/libgfortran/generated/_log_c8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log_c8 (parm) + complex (kind=8), intent (in) :: parm + complex (kind=8) :: _gfortran_specific__log_c8 + + _gfortran_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 000000000..86c19aa8d --- /dev/null +++ b/libgfortran/generated/_log_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__log_r10 + + _gfortran_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 000000000..094a04b89 --- /dev/null +++ b/libgfortran/generated/_log_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__log_r16 + + _gfortran_specific__log_r16 = log (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log_r4.F90 b/libgfortran/generated/_log_r4.F90 new file mode 100644 index 000000000..21dfc77d3 --- /dev/null +++ b/libgfortran/generated/_log_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__log_r4 + + _gfortran_specific__log_r4 = log (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_log_r8.F90 b/libgfortran/generated/_log_r8.F90 new file mode 100644 index 000000000..7d0dc9211 --- /dev/null +++ b/libgfortran/generated/_log_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__log_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__log_r8 + + _gfortran_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 000000000..343699a8b --- /dev/null +++ b/libgfortran/generated/_mod_i16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_16) + + + +elemental function _gfortran_specific__mod_i16 (p1, p2) + integer (kind=16), intent (in) :: p1, p2 + integer (kind=16) :: _gfortran_specific__mod_i16 + + _gfortran_specific__mod_i16 = mod (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_mod_i4.F90 b/libgfortran/generated/_mod_i4.F90 new file mode 100644 index 000000000..47e835294 --- /dev/null +++ b/libgfortran/generated/_mod_i4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_4) + + + +elemental function _gfortran_specific__mod_i4 (p1, p2) + integer (kind=4), intent (in) :: p1, p2 + integer (kind=4) :: _gfortran_specific__mod_i4 + + _gfortran_specific__mod_i4 = mod (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_mod_i8.F90 b/libgfortran/generated/_mod_i8.F90 new file mode 100644 index 000000000..64418d238 --- /dev/null +++ b/libgfortran/generated/_mod_i8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_8) + + + +elemental function _gfortran_specific__mod_i8 (p1, p2) + integer (kind=8), intent (in) :: p1, p2 + integer (kind=8) :: _gfortran_specific__mod_i8 + + _gfortran_specific__mod_i8 = mod (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_mod_r10.F90 b/libgfortran/generated/_mod_r10.F90 new file mode 100644 index 000000000..104a92016 --- /dev/null +++ b/libgfortran/generated/_mod_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) + + + +elemental function _gfortran_specific__mod_r10 (p1, p2) + real (kind=10), intent (in) :: p1, p2 + real (kind=10) :: _gfortran_specific__mod_r10 + + _gfortran_specific__mod_r10 = mod (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_mod_r16.F90 b/libgfortran/generated/_mod_r16.F90 new file mode 100644 index 000000000..13570b1e6 --- /dev/null +++ b/libgfortran/generated/_mod_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) + + + +elemental function _gfortran_specific__mod_r16 (p1, p2) + real (kind=16), intent (in) :: p1, p2 + real (kind=16) :: _gfortran_specific__mod_r16 + + _gfortran_specific__mod_r16 = mod (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_mod_r4.F90 b/libgfortran/generated/_mod_r4.F90 new file mode 100644 index 000000000..a31b65a45 --- /dev/null +++ b/libgfortran/generated/_mod_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) + + + +elemental function _gfortran_specific__mod_r4 (p1, p2) + real (kind=4), intent (in) :: p1, p2 + real (kind=4) :: _gfortran_specific__mod_r4 + + _gfortran_specific__mod_r4 = mod (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_mod_r8.F90 b/libgfortran/generated/_mod_r8.F90 new file mode 100644 index 000000000..931c14141 --- /dev/null +++ b/libgfortran/generated/_mod_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) + + + +elemental function _gfortran_specific__mod_r8 (p1, p2) + real (kind=8), intent (in) :: p1, p2 + real (kind=8) :: _gfortran_specific__mod_r8 + + _gfortran_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 000000000..71e2c655d --- /dev/null +++ b/libgfortran/generated/_sign_i16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_16) + + + +elemental function _gfortran_specific__sign_i16 (p1, p2) + integer (kind=16), intent (in) :: p1, p2 + integer (kind=16) :: _gfortran_specific__sign_i16 + + _gfortran_specific__sign_i16 = sign (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_sign_i4.F90 b/libgfortran/generated/_sign_i4.F90 new file mode 100644 index 000000000..77a632cb4 --- /dev/null +++ b/libgfortran/generated/_sign_i4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_4) + + + +elemental function _gfortran_specific__sign_i4 (p1, p2) + integer (kind=4), intent (in) :: p1, p2 + integer (kind=4) :: _gfortran_specific__sign_i4 + + _gfortran_specific__sign_i4 = sign (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_sign_i8.F90 b/libgfortran/generated/_sign_i8.F90 new file mode 100644 index 000000000..cfd3d40db --- /dev/null +++ b/libgfortran/generated/_sign_i8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_INTEGER_8) + + + +elemental function _gfortran_specific__sign_i8 (p1, p2) + integer (kind=8), intent (in) :: p1, p2 + integer (kind=8) :: _gfortran_specific__sign_i8 + + _gfortran_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 000000000..43a34fc8f --- /dev/null +++ b/libgfortran/generated/_sign_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_10) + + + +elemental function _gfortran_specific__sign_r10 (p1, p2) + real (kind=10), intent (in) :: p1, p2 + real (kind=10) :: _gfortran_specific__sign_r10 + + _gfortran_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 000000000..58ccbebd1 --- /dev/null +++ b/libgfortran/generated/_sign_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_16) + + + +elemental function _gfortran_specific__sign_r16 (p1, p2) + real (kind=16), intent (in) :: p1, p2 + real (kind=16) :: _gfortran_specific__sign_r16 + + _gfortran_specific__sign_r16 = sign (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_sign_r4.F90 b/libgfortran/generated/_sign_r4.F90 new file mode 100644 index 000000000..510b77a44 --- /dev/null +++ b/libgfortran/generated/_sign_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_4) + + + +elemental function _gfortran_specific__sign_r4 (p1, p2) + real (kind=4), intent (in) :: p1, p2 + real (kind=4) :: _gfortran_specific__sign_r4 + + _gfortran_specific__sign_r4 = sign (p1, p2) +end function + + + +#endif diff --git a/libgfortran/generated/_sign_r8.F90 b/libgfortran/generated/_sign_r8.F90 new file mode 100644 index 000000000..107ee1f88 --- /dev/null +++ b/libgfortran/generated/_sign_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + + + +#include "config.h" +#include "kinds.inc" +#include "c99_protos.inc" + +#if defined (HAVE_GFC_REAL_8) + + + +elemental function _gfortran_specific__sign_r8 (p1, p2) + real (kind=8), intent (in) :: p1, p2 + real (kind=8) :: _gfortran_specific__sign_r8 + + _gfortran_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 000000000..9870123c4 --- /dev/null +++ b/libgfortran/generated/_sin_c10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sin_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: _gfortran_specific__sin_c10 + + _gfortran_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 000000000..cc335be68 --- /dev/null +++ b/libgfortran/generated/_sin_c16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sin_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: _gfortran_specific__sin_c16 + + _gfortran_specific__sin_c16 = sin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_c4.F90 b/libgfortran/generated/_sin_c4.F90 new file mode 100644 index 000000000..35f02708e --- /dev/null +++ b/libgfortran/generated/_sin_c4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sin_c4 (parm) + complex (kind=4), intent (in) :: parm + complex (kind=4) :: _gfortran_specific__sin_c4 + + _gfortran_specific__sin_c4 = sin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_c8.F90 b/libgfortran/generated/_sin_c8.F90 new file mode 100644 index 000000000..31eb0950c --- /dev/null +++ b/libgfortran/generated/_sin_c8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sin_c8 (parm) + complex (kind=8), intent (in) :: parm + complex (kind=8) :: _gfortran_specific__sin_c8 + + _gfortran_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 000000000..3cda76226 --- /dev/null +++ b/libgfortran/generated/_sin_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sin_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__sin_r10 + + _gfortran_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 000000000..08ff41ed0 --- /dev/null +++ b/libgfortran/generated/_sin_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sin_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__sin_r16 + + _gfortran_specific__sin_r16 = sin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_r4.F90 b/libgfortran/generated/_sin_r4.F90 new file mode 100644 index 000000000..dd9d02c26 --- /dev/null +++ b/libgfortran/generated/_sin_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sin_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__sin_r4 + + _gfortran_specific__sin_r4 = sin (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sin_r8.F90 b/libgfortran/generated/_sin_r8.F90 new file mode 100644 index 000000000..acdc22573 --- /dev/null +++ b/libgfortran/generated/_sin_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sin_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__sin_r8 + + _gfortran_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 000000000..344cda2c1 --- /dev/null +++ b/libgfortran/generated/_sinh_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sinh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__sinh_r10 + + _gfortran_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 000000000..34b0b5534 --- /dev/null +++ b/libgfortran/generated/_sinh_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sinh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__sinh_r16 + + _gfortran_specific__sinh_r16 = sinh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sinh_r4.F90 b/libgfortran/generated/_sinh_r4.F90 new file mode 100644 index 000000000..6962c7838 --- /dev/null +++ b/libgfortran/generated/_sinh_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sinh_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__sinh_r4 + + _gfortran_specific__sinh_r4 = sinh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sinh_r8.F90 b/libgfortran/generated/_sinh_r8.F90 new file mode 100644 index 000000000..2a8157570 --- /dev/null +++ b/libgfortran/generated/_sinh_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sinh_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__sinh_r8 + + _gfortran_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 000000000..9fe264f40 --- /dev/null +++ b/libgfortran/generated/_sqrt_c10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sqrt_c10 (parm) + complex (kind=10), intent (in) :: parm + complex (kind=10) :: _gfortran_specific__sqrt_c10 + + _gfortran_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 000000000..399182149 --- /dev/null +++ b/libgfortran/generated/_sqrt_c16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sqrt_c16 (parm) + complex (kind=16), intent (in) :: parm + complex (kind=16) :: _gfortran_specific__sqrt_c16 + + _gfortran_specific__sqrt_c16 = sqrt (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_c4.F90 b/libgfortran/generated/_sqrt_c4.F90 new file mode 100644 index 000000000..0a3ae7c36 --- /dev/null +++ b/libgfortran/generated/_sqrt_c4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sqrt_c4 (parm) + complex (kind=4), intent (in) :: parm + complex (kind=4) :: _gfortran_specific__sqrt_c4 + + _gfortran_specific__sqrt_c4 = sqrt (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_c8.F90 b/libgfortran/generated/_sqrt_c8.F90 new file mode 100644 index 000000000..78b22194b --- /dev/null +++ b/libgfortran/generated/_sqrt_c8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sqrt_c8 (parm) + complex (kind=8), intent (in) :: parm + complex (kind=8) :: _gfortran_specific__sqrt_c8 + + _gfortran_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 000000000..37a23f600 --- /dev/null +++ b/libgfortran/generated/_sqrt_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sqrt_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__sqrt_r10 + + _gfortran_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 000000000..3669ae4d2 --- /dev/null +++ b/libgfortran/generated/_sqrt_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sqrt_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__sqrt_r16 + + _gfortran_specific__sqrt_r16 = sqrt (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_r4.F90 b/libgfortran/generated/_sqrt_r4.F90 new file mode 100644 index 000000000..409383605 --- /dev/null +++ b/libgfortran/generated/_sqrt_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sqrt_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__sqrt_r4 + + _gfortran_specific__sqrt_r4 = sqrt (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_sqrt_r8.F90 b/libgfortran/generated/_sqrt_r8.F90 new file mode 100644 index 000000000..a772e10a4 --- /dev/null +++ b/libgfortran/generated/_sqrt_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__sqrt_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__sqrt_r8 + + _gfortran_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 000000000..c087bc60b --- /dev/null +++ b/libgfortran/generated/_tan_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__tan_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__tan_r10 + + _gfortran_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 000000000..d12c1a391 --- /dev/null +++ b/libgfortran/generated/_tan_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__tan_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__tan_r16 + + _gfortran_specific__tan_r16 = tan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_tan_r4.F90 b/libgfortran/generated/_tan_r4.F90 new file mode 100644 index 000000000..4d90a556b --- /dev/null +++ b/libgfortran/generated/_tan_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__tan_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__tan_r4 + + _gfortran_specific__tan_r4 = tan (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_tan_r8.F90 b/libgfortran/generated/_tan_r8.F90 new file mode 100644 index 000000000..4ddf82db5 --- /dev/null +++ b/libgfortran/generated/_tan_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__tan_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__tan_r8 + + _gfortran_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 000000000..ee396b74f --- /dev/null +++ b/libgfortran/generated/_tanh_r10.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__tanh_r10 (parm) + real (kind=10), intent (in) :: parm + real (kind=10) :: _gfortran_specific__tanh_r10 + + _gfortran_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 000000000..41aead446 --- /dev/null +++ b/libgfortran/generated/_tanh_r16.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__tanh_r16 (parm) + real (kind=16), intent (in) :: parm + real (kind=16) :: _gfortran_specific__tanh_r16 + + _gfortran_specific__tanh_r16 = tanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_tanh_r4.F90 b/libgfortran/generated/_tanh_r4.F90 new file mode 100644 index 000000000..5113b8581 --- /dev/null +++ b/libgfortran/generated/_tanh_r4.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__tanh_r4 (parm) + real (kind=4), intent (in) :: parm + real (kind=4) :: _gfortran_specific__tanh_r4 + + _gfortran_specific__tanh_r4 = tanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/_tanh_r8.F90 b/libgfortran/generated/_tanh_r8.F90 new file mode 100644 index 000000000..7b772d328 --- /dev/null +++ b/libgfortran/generated/_tanh_r8.F90 @@ -0,0 +1,46 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!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 _gfortran_specific__tanh_r8 (parm) + real (kind=8), intent (in) :: parm + real (kind=8) :: _gfortran_specific__tanh_r8 + + _gfortran_specific__tanh_r8 = tanh (parm) +end function + +#endif +#endif diff --git a/libgfortran/generated/all_l1.c b/libgfortran/generated/all_l1.c new file mode 100644 index 000000000..edf981848 --- /dev/null +++ b/libgfortran/generated/all_l1.c @@ -0,0 +1,221 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_1) + + +extern void all_l1 (gfc_array_l1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l1); + +void +all_l1 (gfc_array_l1 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_1 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/all_l16.c b/libgfortran/generated/all_l16.c new file mode 100644 index 000000000..d5cde25a9 --- /dev/null +++ b/libgfortran/generated/all_l16.c @@ -0,0 +1,221 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_16) + + +extern void all_l16 (gfc_array_l16 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l16); + +void +all_l16 (gfc_array_l16 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/all_l2.c b/libgfortran/generated/all_l2.c new file mode 100644 index 000000000..1128adabf --- /dev/null +++ b/libgfortran/generated/all_l2.c @@ -0,0 +1,221 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_2) + + +extern void all_l2 (gfc_array_l2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l2); + +void +all_l2 (gfc_array_l2 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_2 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + 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 new file mode 100644 index 000000000..97ad5a4f6 --- /dev/null +++ b/libgfortran/generated/all_l4.c @@ -0,0 +1,221 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_4) + + +extern void all_l4 (gfc_array_l4 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l4); + +void +all_l4 (gfc_array_l4 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/all_l8.c b/libgfortran/generated/all_l8.c new file mode 100644 index 000000000..8846d34e5 --- /dev/null +++ b/libgfortran/generated/all_l8.c @@ -0,0 +1,221 @@ +/* Implementation of the ALL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_8) + + +extern void all_l8 (gfc_array_l8 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(all_l8); + +void +all_l8 (gfc_array_l8 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ALL intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ALL intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ALL intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l1.c b/libgfortran/generated/any_l1.c new file mode 100644 index 000000000..8f52b51fd --- /dev/null +++ b/libgfortran/generated/any_l1.c @@ -0,0 +1,221 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_1) + + +extern void any_l1 (gfc_array_l1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l1); + +void +any_l1 (gfc_array_l1 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_1 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l16.c b/libgfortran/generated/any_l16.c new file mode 100644 index 000000000..7f3f69e11 --- /dev/null +++ b/libgfortran/generated/any_l16.c @@ -0,0 +1,221 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_16) + + +extern void any_l16 (gfc_array_l16 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l16); + +void +any_l16 (gfc_array_l16 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l2.c b/libgfortran/generated/any_l2.c new file mode 100644 index 000000000..d2c4dbedb --- /dev/null +++ b/libgfortran/generated/any_l2.c @@ -0,0 +1,221 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_2) + + +extern void any_l2 (gfc_array_l2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l2); + +void +any_l2 (gfc_array_l2 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_2 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + 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 new file mode 100644 index 000000000..f9d563743 --- /dev/null +++ b/libgfortran/generated/any_l4.c @@ -0,0 +1,221 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_4) + + +extern void any_l4 (gfc_array_l4 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l4); + +void +any_l4 (gfc_array_l4 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/any_l8.c b/libgfortran/generated/any_l8.c new file mode 100644 index 000000000..f595826cc --- /dev/null +++ b/libgfortran/generated/any_l8.c @@ -0,0 +1,221 @@ +/* Implementation of the ANY intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_8) + + +extern void any_l8 (gfc_array_l8 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(any_l8); + +void +any_l8 (gfc_array_l8 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " ANY intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " ANY intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in ANY intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/bessel_r10.c b/libgfortran/generated/bessel_r10.c new file mode 100644 index 000000000..87599fea6 --- /dev/null +++ b/libgfortran/generated/bessel_r10.c @@ -0,0 +1,187 @@ +/* Implementation of the BESSEL_JN and BESSEL_YN transformational + function using a recurrence algorithm. + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + + +#define MATHFUNC(funcname) funcname ## l +#define BUILTINMATHFUNC(funcname) MATHFUNC(funcname) + +#if defined (HAVE_GFC_REAL_10) + + + +#if defined (HAVE_JNL) +extern void bessel_jn_r10 (gfc_array_r10 * const restrict ret, int n1, + int n2, GFC_REAL_10 x); +export_proto(bessel_jn_r10); + +void +bessel_jn_r10 (gfc_array_r10 * const restrict ret, int n1, int n2, GFC_REAL_10 x) +{ + int i; + index_type stride; + + GFC_REAL_10 last1, last2, x2rev; + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (ret->data == NULL) + { + size_t size = n2 < n1 ? 0 : n2-n1+1; + GFC_DIMENSION_SET(ret->dim[0], 0, size-1, 1); + ret->data = internal_malloc_size (sizeof (GFC_REAL_10) * size); + ret->offset = 0; + } + + if (unlikely (n2 < n1)) + return; + + if (unlikely (compile_options.bounds_check) + && GFC_DESCRIPTOR_EXTENT(ret,0) != (n2-n1+1)) + runtime_error("Incorrect extent in return value of BESSEL_JN " + "(%ld vs. %ld)", (long int) n2-n1, + (long int) GFC_DESCRIPTOR_EXTENT(ret,0)); + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (unlikely (x == 0)) + { + ret->data[0] = 1; + for (i = 1; i <= n2-n1; i++) + ret->data[i*stride] = 0; + return; + } + + ret->data = ret->data; + last1 = MATHFUNC(jn) (n2, x); + ret->data[(n2-n1)*stride] = last1; + + if (n1 == n2) + return; + + last2 = MATHFUNC(jn) (n2 - 1, x); + ret->data[(n2-n1-1)*stride] = last2; + + if (n1 + 1 == n2) + return; + + x2rev = GFC_REAL_10_LITERAL(2.)/x; + + for (i = n2-n1-2; i >= 0; i--) + { + ret->data[i*stride] = x2rev * (i+1+n1) * last2 - last1; + last1 = last2; + last2 = ret->data[i*stride]; + } +} + +#endif + +#if defined (HAVE_YNL) +extern void bessel_yn_r10 (gfc_array_r10 * const restrict ret, + int n1, int n2, GFC_REAL_10 x); +export_proto(bessel_yn_r10); + +void +bessel_yn_r10 (gfc_array_r10 * const restrict ret, int n1, int n2, + GFC_REAL_10 x) +{ + int i; + index_type stride; + + GFC_REAL_10 last1, last2, x2rev; + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (ret->data == NULL) + { + size_t size = n2 < n1 ? 0 : n2-n1+1; + GFC_DIMENSION_SET(ret->dim[0], 0, size-1, 1); + ret->data = internal_malloc_size (sizeof (GFC_REAL_10) * size); + ret->offset = 0; + } + + if (unlikely (n2 < n1)) + return; + + if (unlikely (compile_options.bounds_check) + && GFC_DESCRIPTOR_EXTENT(ret,0) != (n2-n1+1)) + runtime_error("Incorrect extent in return value of BESSEL_JN " + "(%ld vs. %ld)", (long int) n2-n1, + (long int) GFC_DESCRIPTOR_EXTENT(ret,0)); + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (unlikely (x == 0)) + { + for (i = 0; i <= n2-n1; i++) +#if defined(GFC_REAL_10_INFINITY) + ret->data[i*stride] = -GFC_REAL_10_INFINITY; +#else + ret->data[i*stride] = -GFC_REAL_10_HUGE; +#endif + return; + } + + ret->data = ret->data; + last1 = MATHFUNC(yn) (n1, x); + ret->data[0] = last1; + + if (n1 == n2) + return; + + last2 = MATHFUNC(yn) (n1 + 1, x); + ret->data[1*stride] = last2; + + if (n1 + 1 == n2) + return; + + x2rev = GFC_REAL_10_LITERAL(2.)/x; + + for (i = 2; i <= n1+n2; i++) + { +#if defined(GFC_REAL_10_INFINITY) + if (unlikely (last2 == -GFC_REAL_10_INFINITY)) + { + ret->data[i*stride] = -GFC_REAL_10_INFINITY; + } + else +#endif + { + ret->data[i*stride] = x2rev * (i-1+n1) * last2 - last1; + last1 = last2; + last2 = ret->data[i*stride]; + } + } +} +#endif + +#endif + diff --git a/libgfortran/generated/bessel_r16.c b/libgfortran/generated/bessel_r16.c new file mode 100644 index 000000000..7097f6b04 --- /dev/null +++ b/libgfortran/generated/bessel_r16.c @@ -0,0 +1,195 @@ +/* Implementation of the BESSEL_JN and BESSEL_YN transformational + function using a recurrence algorithm. + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + + +#if defined(GFC_REAL_16_IS_FLOAT128) +#define MATHFUNC(funcname) funcname ## q +#else +#define MATHFUNC(funcname) funcname ## l +#endif +#if defined(GFC_REAL_16_IS_FLOAT128) +#define BUILTINMATHFUNC(funcname) funcname ## q +#else +#define BUILTINMATHFUNC(funcname) funcname ## l +#endif + +#if defined (HAVE_GFC_REAL_16) + + + +#if (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_JNL)) +extern void bessel_jn_r16 (gfc_array_r16 * const restrict ret, int n1, + int n2, GFC_REAL_16 x); +export_proto(bessel_jn_r16); + +void +bessel_jn_r16 (gfc_array_r16 * const restrict ret, int n1, int n2, GFC_REAL_16 x) +{ + int i; + index_type stride; + + GFC_REAL_16 last1, last2, x2rev; + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (ret->data == NULL) + { + size_t size = n2 < n1 ? 0 : n2-n1+1; + GFC_DIMENSION_SET(ret->dim[0], 0, size-1, 1); + ret->data = internal_malloc_size (sizeof (GFC_REAL_16) * size); + ret->offset = 0; + } + + if (unlikely (n2 < n1)) + return; + + if (unlikely (compile_options.bounds_check) + && GFC_DESCRIPTOR_EXTENT(ret,0) != (n2-n1+1)) + runtime_error("Incorrect extent in return value of BESSEL_JN " + "(%ld vs. %ld)", (long int) n2-n1, + (long int) GFC_DESCRIPTOR_EXTENT(ret,0)); + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (unlikely (x == 0)) + { + ret->data[0] = 1; + for (i = 1; i <= n2-n1; i++) + ret->data[i*stride] = 0; + return; + } + + ret->data = ret->data; + last1 = MATHFUNC(jn) (n2, x); + ret->data[(n2-n1)*stride] = last1; + + if (n1 == n2) + return; + + last2 = MATHFUNC(jn) (n2 - 1, x); + ret->data[(n2-n1-1)*stride] = last2; + + if (n1 + 1 == n2) + return; + + x2rev = GFC_REAL_16_LITERAL(2.)/x; + + for (i = n2-n1-2; i >= 0; i--) + { + ret->data[i*stride] = x2rev * (i+1+n1) * last2 - last1; + last1 = last2; + last2 = ret->data[i*stride]; + } +} + +#endif + +#if (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_YNL)) +extern void bessel_yn_r16 (gfc_array_r16 * const restrict ret, + int n1, int n2, GFC_REAL_16 x); +export_proto(bessel_yn_r16); + +void +bessel_yn_r16 (gfc_array_r16 * const restrict ret, int n1, int n2, + GFC_REAL_16 x) +{ + int i; + index_type stride; + + GFC_REAL_16 last1, last2, x2rev; + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (ret->data == NULL) + { + size_t size = n2 < n1 ? 0 : n2-n1+1; + GFC_DIMENSION_SET(ret->dim[0], 0, size-1, 1); + ret->data = internal_malloc_size (sizeof (GFC_REAL_16) * size); + ret->offset = 0; + } + + if (unlikely (n2 < n1)) + return; + + if (unlikely (compile_options.bounds_check) + && GFC_DESCRIPTOR_EXTENT(ret,0) != (n2-n1+1)) + runtime_error("Incorrect extent in return value of BESSEL_JN " + "(%ld vs. %ld)", (long int) n2-n1, + (long int) GFC_DESCRIPTOR_EXTENT(ret,0)); + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (unlikely (x == 0)) + { + for (i = 0; i <= n2-n1; i++) +#if defined(GFC_REAL_16_INFINITY) + ret->data[i*stride] = -GFC_REAL_16_INFINITY; +#else + ret->data[i*stride] = -GFC_REAL_16_HUGE; +#endif + return; + } + + ret->data = ret->data; + last1 = MATHFUNC(yn) (n1, x); + ret->data[0] = last1; + + if (n1 == n2) + return; + + last2 = MATHFUNC(yn) (n1 + 1, x); + ret->data[1*stride] = last2; + + if (n1 + 1 == n2) + return; + + x2rev = GFC_REAL_16_LITERAL(2.)/x; + + for (i = 2; i <= n1+n2; i++) + { +#if defined(GFC_REAL_16_INFINITY) + if (unlikely (last2 == -GFC_REAL_16_INFINITY)) + { + ret->data[i*stride] = -GFC_REAL_16_INFINITY; + } + else +#endif + { + ret->data[i*stride] = x2rev * (i-1+n1) * last2 - last1; + last1 = last2; + last2 = ret->data[i*stride]; + } + } +} +#endif + +#endif + diff --git a/libgfortran/generated/bessel_r4.c b/libgfortran/generated/bessel_r4.c new file mode 100644 index 000000000..75d2ff0a8 --- /dev/null +++ b/libgfortran/generated/bessel_r4.c @@ -0,0 +1,187 @@ +/* Implementation of the BESSEL_JN and BESSEL_YN transformational + function using a recurrence algorithm. + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + + +#define MATHFUNC(funcname) funcname ## f +#define BUILTINMATHFUNC(funcname) MATHFUNC(funcname) + +#if defined (HAVE_GFC_REAL_4) + + + +#if defined (HAVE_JNF) +extern void bessel_jn_r4 (gfc_array_r4 * const restrict ret, int n1, + int n2, GFC_REAL_4 x); +export_proto(bessel_jn_r4); + +void +bessel_jn_r4 (gfc_array_r4 * const restrict ret, int n1, int n2, GFC_REAL_4 x) +{ + int i; + index_type stride; + + GFC_REAL_4 last1, last2, x2rev; + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (ret->data == NULL) + { + size_t size = n2 < n1 ? 0 : n2-n1+1; + GFC_DIMENSION_SET(ret->dim[0], 0, size-1, 1); + ret->data = internal_malloc_size (sizeof (GFC_REAL_4) * size); + ret->offset = 0; + } + + if (unlikely (n2 < n1)) + return; + + if (unlikely (compile_options.bounds_check) + && GFC_DESCRIPTOR_EXTENT(ret,0) != (n2-n1+1)) + runtime_error("Incorrect extent in return value of BESSEL_JN " + "(%ld vs. %ld)", (long int) n2-n1, + (long int) GFC_DESCRIPTOR_EXTENT(ret,0)); + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (unlikely (x == 0)) + { + ret->data[0] = 1; + for (i = 1; i <= n2-n1; i++) + ret->data[i*stride] = 0; + return; + } + + ret->data = ret->data; + last1 = MATHFUNC(jn) (n2, x); + ret->data[(n2-n1)*stride] = last1; + + if (n1 == n2) + return; + + last2 = MATHFUNC(jn) (n2 - 1, x); + ret->data[(n2-n1-1)*stride] = last2; + + if (n1 + 1 == n2) + return; + + x2rev = GFC_REAL_4_LITERAL(2.)/x; + + for (i = n2-n1-2; i >= 0; i--) + { + ret->data[i*stride] = x2rev * (i+1+n1) * last2 - last1; + last1 = last2; + last2 = ret->data[i*stride]; + } +} + +#endif + +#if defined (HAVE_YNF) +extern void bessel_yn_r4 (gfc_array_r4 * const restrict ret, + int n1, int n2, GFC_REAL_4 x); +export_proto(bessel_yn_r4); + +void +bessel_yn_r4 (gfc_array_r4 * const restrict ret, int n1, int n2, + GFC_REAL_4 x) +{ + int i; + index_type stride; + + GFC_REAL_4 last1, last2, x2rev; + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (ret->data == NULL) + { + size_t size = n2 < n1 ? 0 : n2-n1+1; + GFC_DIMENSION_SET(ret->dim[0], 0, size-1, 1); + ret->data = internal_malloc_size (sizeof (GFC_REAL_4) * size); + ret->offset = 0; + } + + if (unlikely (n2 < n1)) + return; + + if (unlikely (compile_options.bounds_check) + && GFC_DESCRIPTOR_EXTENT(ret,0) != (n2-n1+1)) + runtime_error("Incorrect extent in return value of BESSEL_JN " + "(%ld vs. %ld)", (long int) n2-n1, + (long int) GFC_DESCRIPTOR_EXTENT(ret,0)); + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (unlikely (x == 0)) + { + for (i = 0; i <= n2-n1; i++) +#if defined(GFC_REAL_4_INFINITY) + ret->data[i*stride] = -GFC_REAL_4_INFINITY; +#else + ret->data[i*stride] = -GFC_REAL_4_HUGE; +#endif + return; + } + + ret->data = ret->data; + last1 = MATHFUNC(yn) (n1, x); + ret->data[0] = last1; + + if (n1 == n2) + return; + + last2 = MATHFUNC(yn) (n1 + 1, x); + ret->data[1*stride] = last2; + + if (n1 + 1 == n2) + return; + + x2rev = GFC_REAL_4_LITERAL(2.)/x; + + for (i = 2; i <= n1+n2; i++) + { +#if defined(GFC_REAL_4_INFINITY) + if (unlikely (last2 == -GFC_REAL_4_INFINITY)) + { + ret->data[i*stride] = -GFC_REAL_4_INFINITY; + } + else +#endif + { + ret->data[i*stride] = x2rev * (i-1+n1) * last2 - last1; + last1 = last2; + last2 = ret->data[i*stride]; + } + } +} +#endif + +#endif + diff --git a/libgfortran/generated/bessel_r8.c b/libgfortran/generated/bessel_r8.c new file mode 100644 index 000000000..899237b1e --- /dev/null +++ b/libgfortran/generated/bessel_r8.c @@ -0,0 +1,187 @@ +/* Implementation of the BESSEL_JN and BESSEL_YN transformational + function using a recurrence algorithm. + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + + +#define MATHFUNC(funcname) funcname +#define BUILTINMATHFUNC(funcname) MATHFUNC(funcname) + +#if defined (HAVE_GFC_REAL_8) + + + +#if defined (HAVE_JN) +extern void bessel_jn_r8 (gfc_array_r8 * const restrict ret, int n1, + int n2, GFC_REAL_8 x); +export_proto(bessel_jn_r8); + +void +bessel_jn_r8 (gfc_array_r8 * const restrict ret, int n1, int n2, GFC_REAL_8 x) +{ + int i; + index_type stride; + + GFC_REAL_8 last1, last2, x2rev; + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (ret->data == NULL) + { + size_t size = n2 < n1 ? 0 : n2-n1+1; + GFC_DIMENSION_SET(ret->dim[0], 0, size-1, 1); + ret->data = internal_malloc_size (sizeof (GFC_REAL_8) * size); + ret->offset = 0; + } + + if (unlikely (n2 < n1)) + return; + + if (unlikely (compile_options.bounds_check) + && GFC_DESCRIPTOR_EXTENT(ret,0) != (n2-n1+1)) + runtime_error("Incorrect extent in return value of BESSEL_JN " + "(%ld vs. %ld)", (long int) n2-n1, + (long int) GFC_DESCRIPTOR_EXTENT(ret,0)); + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (unlikely (x == 0)) + { + ret->data[0] = 1; + for (i = 1; i <= n2-n1; i++) + ret->data[i*stride] = 0; + return; + } + + ret->data = ret->data; + last1 = MATHFUNC(jn) (n2, x); + ret->data[(n2-n1)*stride] = last1; + + if (n1 == n2) + return; + + last2 = MATHFUNC(jn) (n2 - 1, x); + ret->data[(n2-n1-1)*stride] = last2; + + if (n1 + 1 == n2) + return; + + x2rev = GFC_REAL_8_LITERAL(2.)/x; + + for (i = n2-n1-2; i >= 0; i--) + { + ret->data[i*stride] = x2rev * (i+1+n1) * last2 - last1; + last1 = last2; + last2 = ret->data[i*stride]; + } +} + +#endif + +#if defined (HAVE_YN) +extern void bessel_yn_r8 (gfc_array_r8 * const restrict ret, + int n1, int n2, GFC_REAL_8 x); +export_proto(bessel_yn_r8); + +void +bessel_yn_r8 (gfc_array_r8 * const restrict ret, int n1, int n2, + GFC_REAL_8 x) +{ + int i; + index_type stride; + + GFC_REAL_8 last1, last2, x2rev; + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (ret->data == NULL) + { + size_t size = n2 < n1 ? 0 : n2-n1+1; + GFC_DIMENSION_SET(ret->dim[0], 0, size-1, 1); + ret->data = internal_malloc_size (sizeof (GFC_REAL_8) * size); + ret->offset = 0; + } + + if (unlikely (n2 < n1)) + return; + + if (unlikely (compile_options.bounds_check) + && GFC_DESCRIPTOR_EXTENT(ret,0) != (n2-n1+1)) + runtime_error("Incorrect extent in return value of BESSEL_JN " + "(%ld vs. %ld)", (long int) n2-n1, + (long int) GFC_DESCRIPTOR_EXTENT(ret,0)); + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (unlikely (x == 0)) + { + for (i = 0; i <= n2-n1; i++) +#if defined(GFC_REAL_8_INFINITY) + ret->data[i*stride] = -GFC_REAL_8_INFINITY; +#else + ret->data[i*stride] = -GFC_REAL_8_HUGE; +#endif + return; + } + + ret->data = ret->data; + last1 = MATHFUNC(yn) (n1, x); + ret->data[0] = last1; + + if (n1 == n2) + return; + + last2 = MATHFUNC(yn) (n1 + 1, x); + ret->data[1*stride] = last2; + + if (n1 + 1 == n2) + return; + + x2rev = GFC_REAL_8_LITERAL(2.)/x; + + for (i = 2; i <= n1+n2; i++) + { +#if defined(GFC_REAL_8_INFINITY) + if (unlikely (last2 == -GFC_REAL_8_INFINITY)) + { + ret->data[i*stride] = -GFC_REAL_8_INFINITY; + } + else +#endif + { + ret->data[i*stride] = x2rev * (i-1+n1) * last2 - last1; + last1 = last2; + last2 = ret->data[i*stride]; + } + } +} +#endif + +#endif + diff --git a/libgfortran/generated/count_16_l.c b/libgfortran/generated/count_16_l.c new file mode 100644 index 000000000..e894e561d --- /dev/null +++ b/libgfortran/generated/count_16_l.c @@ -0,0 +1,217 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + + +extern void count_16_l (gfc_array_i16 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_16_l); + +void +count_16_l (gfc_array_i16 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_1_l.c b/libgfortran/generated/count_1_l.c new file mode 100644 index 000000000..894ad0c29 --- /dev/null +++ b/libgfortran/generated/count_1_l.c @@ -0,0 +1,217 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + + +extern void count_1_l (gfc_array_i1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_1_l); + +void +count_1_l (gfc_array_i1 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_INTEGER_1 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_2_l.c b/libgfortran/generated/count_2_l.c new file mode 100644 index 000000000..d0e5ee497 --- /dev/null +++ b/libgfortran/generated/count_2_l.c @@ -0,0 +1,217 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + + +extern void count_2_l (gfc_array_i2 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_2_l); + +void +count_2_l (gfc_array_i2 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_INTEGER_2 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_4_l.c b/libgfortran/generated/count_4_l.c new file mode 100644 index 000000000..43af56b78 --- /dev/null +++ b/libgfortran/generated/count_4_l.c @@ -0,0 +1,217 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + + +extern void count_4_l (gfc_array_i4 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_4_l); + +void +count_4_l (gfc_array_i4 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/count_8_l.c b/libgfortran/generated/count_8_l.c new file mode 100644 index 000000000..6ddd701f9 --- /dev/null +++ b/libgfortran/generated/count_8_l.c @@ -0,0 +1,217 @@ +/* Implementation of the COUNT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + + +extern void count_8_l (gfc_array_i8 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(count_8_l); + +void +count_8_l (gfc_array_i8 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int src_kind; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + src_kind = GFC_DESCRIPTOR_SIZE (array); + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " COUNT intrinsic: is %ld, should be %ld", + (long int) GFC_DESCRIPTOR_RANK (retarray), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " COUNT intrinsic in dimension %d:" + " is %ld, should be %ld", (int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + + if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || src_kind == 16 +#endif + ) + { + if (base) + base = GFOR_POINTER_TO_L1 (base, src_kind); + } + else + internal_error (NULL, "Funny sized logical array in COUNT intrinsic"); + + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/cshift0_c10.c b/libgfortran/generated/cshift0_c10.c new file mode 100644 index 000000000..16c113deb --- /dev/null +++ b/libgfortran/generated/cshift0_c10.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) + +void +cshift0_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_COMPLEX_10 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_COMPLEX_10 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_COMPLEX_10); + size_t len2 = (len - shift) * sizeof (GFC_COMPLEX_10); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_COMPLEX_10 *dest = rptr; + const GFC_COMPLEX_10 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_c16.c b/libgfortran/generated/cshift0_c16.c new file mode 100644 index 000000000..df83ccb85 --- /dev/null +++ b/libgfortran/generated/cshift0_c16.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) + +void +cshift0_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_COMPLEX_16 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_COMPLEX_16 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_COMPLEX_16); + size_t len2 = (len - shift) * sizeof (GFC_COMPLEX_16); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_COMPLEX_16 *dest = rptr; + const GFC_COMPLEX_16 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_c4.c b/libgfortran/generated/cshift0_c4.c new file mode 100644 index 000000000..52d277f1c --- /dev/null +++ b/libgfortran/generated/cshift0_c4.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +void +cshift0_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_COMPLEX_4 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_COMPLEX_4 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_COMPLEX_4); + size_t len2 = (len - shift) * sizeof (GFC_COMPLEX_4); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_COMPLEX_4 *dest = rptr; + const GFC_COMPLEX_4 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_c8.c b/libgfortran/generated/cshift0_c8.c new file mode 100644 index 000000000..9b9c3b2ac --- /dev/null +++ b/libgfortran/generated/cshift0_c8.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +void +cshift0_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_COMPLEX_8 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_COMPLEX_8 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_COMPLEX_8); + size_t len2 = (len - shift) * sizeof (GFC_COMPLEX_8); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_COMPLEX_8 *dest = rptr; + const GFC_COMPLEX_8 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_i1.c b/libgfortran/generated/cshift0_i1.c new file mode 100644 index 000000000..7ed44bddb --- /dev/null +++ b/libgfortran/generated/cshift0_i1.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + +void +cshift0_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_INTEGER_1 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_INTEGER_1 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_INTEGER_1); + size_t len2 = (len - shift) * sizeof (GFC_INTEGER_1); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_INTEGER_1 *dest = rptr; + const GFC_INTEGER_1 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_i16.c b/libgfortran/generated/cshift0_i16.c new file mode 100644 index 000000000..145724b6e --- /dev/null +++ b/libgfortran/generated/cshift0_i16.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +void +cshift0_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_INTEGER_16 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_INTEGER_16 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_INTEGER_16); + size_t len2 = (len - shift) * sizeof (GFC_INTEGER_16); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_INTEGER_16 *dest = rptr; + const GFC_INTEGER_16 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_i2.c b/libgfortran/generated/cshift0_i2.c new file mode 100644 index 000000000..df3328175 --- /dev/null +++ b/libgfortran/generated/cshift0_i2.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + +void +cshift0_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_INTEGER_2 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_INTEGER_2 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_INTEGER_2); + size_t len2 = (len - shift) * sizeof (GFC_INTEGER_2); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_INTEGER_2 *dest = rptr; + const GFC_INTEGER_2 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_i4.c b/libgfortran/generated/cshift0_i4.c new file mode 100644 index 000000000..a1e118589 --- /dev/null +++ b/libgfortran/generated/cshift0_i4.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +void +cshift0_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_INTEGER_4 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_INTEGER_4 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_INTEGER_4); + size_t len2 = (len - shift) * sizeof (GFC_INTEGER_4); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_INTEGER_4 *dest = rptr; + const GFC_INTEGER_4 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_i8.c b/libgfortran/generated/cshift0_i8.c new file mode 100644 index 000000000..cbe13f153 --- /dev/null +++ b/libgfortran/generated/cshift0_i8.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +void +cshift0_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_INTEGER_8 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_INTEGER_8 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_INTEGER_8); + size_t len2 = (len - shift) * sizeof (GFC_INTEGER_8); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_INTEGER_8 *dest = rptr; + const GFC_INTEGER_8 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_r10.c b/libgfortran/generated/cshift0_r10.c new file mode 100644 index 000000000..8ba544d2d --- /dev/null +++ b/libgfortran/generated/cshift0_r10.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +void +cshift0_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_REAL_10 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_REAL_10 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_REAL_10); + size_t len2 = (len - shift) * sizeof (GFC_REAL_10); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_REAL_10 *dest = rptr; + const GFC_REAL_10 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_r16.c b/libgfortran/generated/cshift0_r16.c new file mode 100644 index 000000000..0725048c2 --- /dev/null +++ b/libgfortran/generated/cshift0_r16.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +void +cshift0_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_REAL_16 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_REAL_16 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_REAL_16); + size_t len2 = (len - shift) * sizeof (GFC_REAL_16); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_REAL_16 *dest = rptr; + const GFC_REAL_16 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_r4.c b/libgfortran/generated/cshift0_r4.c new file mode 100644 index 000000000..515c36b41 --- /dev/null +++ b/libgfortran/generated/cshift0_r4.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +void +cshift0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_REAL_4 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_REAL_4 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_REAL_4); + size_t len2 = (len - shift) * sizeof (GFC_REAL_4); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_REAL_4 *dest = rptr; + const GFC_REAL_4 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift0_r8.c b/libgfortran/generated/cshift0_r8.c new file mode 100644 index 000000000..5a721e495 --- /dev/null +++ b/libgfortran/generated/cshift0_r8.c @@ -0,0 +1,171 @@ +/* Helper function for cshift functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +void +cshift0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, ssize_t shift, + int which) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + GFC_REAL_8 *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const GFC_REAL_8 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = 1; + soffset = 1; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE(ret,dim); + if (roffset == 0) + roffset = 1; + soffset = GFC_DESCRIPTOR_STRIDE(array,dim); + if (soffset == 0) + soffset = 1; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim); + n++; + } + } + if (sstride[0] == 0) + sstride[0] = 1; + if (rstride[0] == 0) + rstride[0] = 1; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == 1 && roffset == 1) + { + size_t len1 = shift * sizeof (GFC_REAL_8); + size_t len2 = (len - shift) * sizeof (GFC_REAL_8); + memcpy (rptr, sptr + shift, len2); + memcpy (rptr + (len - shift), sptr, len1); + } + else + { + /* Otherwise, we will have to perform the copy one element at + a time. */ + GFC_REAL_8 *dest = rptr; + const GFC_REAL_8 *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + *dest = *src; + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[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]; + } + } + } + + return; +} + +#endif diff --git a/libgfortran/generated/cshift1_16.c b/libgfortran/generated/cshift1_16.c new file mode 100644 index 000000000..b2cb7f17c --- /dev/null +++ b/libgfortran/generated/cshift1_16.c @@ -0,0 +1,273 @@ +/* Implementation of the CSHIFT intrinsic + Copyright 2003, 2007, 2009 Free Software Foundation, Inc. + Contributed by Feng Wang + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +static void +cshift1 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich) +{ + /* 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; + index_type arraysize; + index_type size; + + 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'"); + + size = GFC_DESCRIPTOR_SIZE(array); + + arraysize = size0 ((array_t *)array); + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * arraysize); + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) * + GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + } + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "CSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "CSHIFT"); + } + + if (arraysize == 0) + return; + + 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 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + 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; + 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 probably 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 restrict, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const GFC_INTEGER_16 * const restrict); +export_proto(cshift1_16); + +void +cshift1_16 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich) +{ + cshift1 (ret, array, h, pwhich); +} + + +void cshift1_16_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_16_char); + +void +cshift1_16_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused))) +{ + cshift1 (ret, array, h, pwhich); +} + + +void cshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_16_char4); + +void +cshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused))) +{ + cshift1 (ret, array, h, pwhich); +} + +#endif diff --git a/libgfortran/generated/cshift1_4.c b/libgfortran/generated/cshift1_4.c new file mode 100644 index 000000000..30f3d99dc --- /dev/null +++ b/libgfortran/generated/cshift1_4.c @@ -0,0 +1,273 @@ +/* Implementation of the CSHIFT intrinsic + Copyright 2003, 2007, 2009 Free Software Foundation, Inc. + Contributed by Feng Wang + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +static void +cshift1 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich) +{ + /* 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_4 *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_4 sh; + index_type arraysize; + index_type size; + + 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'"); + + size = GFC_DESCRIPTOR_SIZE(array); + + arraysize = size0 ((array_t *)array); + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * arraysize); + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) * + GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + } + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "CSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "CSHIFT"); + } + + if (arraysize == 0) + return; + + 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 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + 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; + 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 probably 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_4 (gfc_array_char * const restrict, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const GFC_INTEGER_4 * const restrict); +export_proto(cshift1_4); + +void +cshift1_4 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich) +{ + cshift1 (ret, array, h, pwhich); +} + + +void cshift1_4_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_4_char); + +void +cshift1_4_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused))) +{ + cshift1 (ret, array, h, pwhich); +} + + +void cshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_4_char4); + +void +cshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused))) +{ + cshift1 (ret, array, h, pwhich); +} + +#endif diff --git a/libgfortran/generated/cshift1_8.c b/libgfortran/generated/cshift1_8.c new file mode 100644 index 000000000..c3bf473e4 --- /dev/null +++ b/libgfortran/generated/cshift1_8.c @@ -0,0 +1,273 @@ +/* Implementation of the CSHIFT intrinsic + Copyright 2003, 2007, 2009 Free Software Foundation, Inc. + Contributed by Feng Wang + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +static void +cshift1 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich) +{ + /* 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_8 *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_8 sh; + index_type arraysize; + index_type size; + + 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'"); + + size = GFC_DESCRIPTOR_SIZE(array); + + arraysize = size0 ((array_t *)array); + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * arraysize); + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) * + GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + } + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "CSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "CSHIFT"); + } + + if (arraysize == 0) + return; + + 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 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + 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; + 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 probably 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_8 (gfc_array_char * const restrict, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const GFC_INTEGER_8 * const restrict); +export_proto(cshift1_8); + +void +cshift1_8 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich) +{ + cshift1 (ret, array, h, pwhich); +} + + +void cshift1_8_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_8_char); + +void +cshift1_8_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused))) +{ + cshift1 (ret, array, h, pwhich); +} + + +void cshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4); +export_proto(cshift1_8_char4); + +void +cshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused))) +{ + cshift1 (ret, array, h, pwhich); +} + +#endif diff --git a/libgfortran/generated/eoshift1_16.c b/libgfortran/generated/eoshift1_16.c new file mode 100644 index 000000000..48fa03b67 --- /dev/null +++ b/libgfortran/generated/eoshift1_16.c @@ -0,0 +1,318 @@ +/* Implementation of the EOSHIFT intrinsic + Copyright 2002, 2005, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +static void +eoshift1 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_16 * const restrict pwhich, + const char * filler, index_type filler_len) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char * restrict 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; + index_type size; + index_type arraysize; + 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; + + size = GFC_DESCRIPTOR_SIZE(array); + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + extent[0] = 1; + count[0] = 0; + + arraysize = size0 ((array_t *) array); + if (ret->data == NULL) + { + int i; + + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) + * GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + + } + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + ret->data = internal_malloc_size (1); + + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "EOSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "EOSHIFT"); + } + + if (arraysize == 0) + return; + + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + 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--) + { + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + + 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 probably 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 restrict, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, const char * const restrict, + const GFC_INTEGER_16 * const restrict); +export_proto(eoshift1_16); + +void +eoshift1_16 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_16 * const restrict pwhich) +{ + eoshift1 (ret, array, h, pbound, pwhich, "\0", 1); +} + + +void eoshift1_16_char (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const char * const restrict, + const GFC_INTEGER_16 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_16_char); + +void +eoshift1_16_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + eoshift1 (ret, array, h, pbound, pwhich, " ", 1); +} + + +void eoshift1_16_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const char * const restrict, + const GFC_INTEGER_16 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_16_char4); + +void +eoshift1_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, + (const char *) &space, sizeof (gfc_char4_t)); +} + +#endif diff --git a/libgfortran/generated/eoshift1_4.c b/libgfortran/generated/eoshift1_4.c new file mode 100644 index 000000000..3b9f7309c --- /dev/null +++ b/libgfortran/generated/eoshift1_4.c @@ -0,0 +1,318 @@ +/* Implementation of the EOSHIFT intrinsic + Copyright 2002, 2005, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +static void +eoshift1 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_4 * const restrict pwhich, + const char * filler, index_type filler_len) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char * restrict 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_4 *hptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + index_type size; + index_type arraysize; + int which; + GFC_INTEGER_4 sh; + GFC_INTEGER_4 delta; + + /* The compiler cannot figure out that these are set, initialize + them to avoid warnings. */ + len = 0; + soffset = 0; + roffset = 0; + + size = GFC_DESCRIPTOR_SIZE(array); + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + extent[0] = 1; + count[0] = 0; + + arraysize = size0 ((array_t *) array); + if (ret->data == NULL) + { + int i; + + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) + * GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + + } + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + ret->data = internal_malloc_size (1); + + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "EOSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "EOSHIFT"); + } + + if (arraysize == 0) + return; + + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + 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--) + { + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + + 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 probably 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_4 (gfc_array_char * const restrict, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, const char * const restrict, + const GFC_INTEGER_4 * const restrict); +export_proto(eoshift1_4); + +void +eoshift1_4 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_4 * const restrict pwhich) +{ + eoshift1 (ret, array, h, pbound, pwhich, "\0", 1); +} + + +void eoshift1_4_char (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const char * const restrict, + const GFC_INTEGER_4 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_4_char); + +void +eoshift1_4_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + eoshift1 (ret, array, h, pbound, pwhich, " ", 1); +} + + +void eoshift1_4_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const char * const restrict, + const GFC_INTEGER_4 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_4_char4); + +void +eoshift1_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, + (const char *) &space, sizeof (gfc_char4_t)); +} + +#endif diff --git a/libgfortran/generated/eoshift1_8.c b/libgfortran/generated/eoshift1_8.c new file mode 100644 index 000000000..60c8667bd --- /dev/null +++ b/libgfortran/generated/eoshift1_8.c @@ -0,0 +1,318 @@ +/* Implementation of the EOSHIFT intrinsic + Copyright 2002, 2005, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +static void +eoshift1 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_8 * const restrict pwhich, + const char * filler, index_type filler_len) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char * restrict 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_8 *hptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + index_type size; + index_type arraysize; + int which; + GFC_INTEGER_8 sh; + GFC_INTEGER_8 delta; + + /* The compiler cannot figure out that these are set, initialize + them to avoid warnings. */ + len = 0; + soffset = 0; + roffset = 0; + + size = GFC_DESCRIPTOR_SIZE(array); + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + extent[0] = 1; + count[0] = 0; + + arraysize = size0 ((array_t *) array); + if (ret->data == NULL) + { + int i; + + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) + * GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + + } + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + ret->data = internal_malloc_size (1); + + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "EOSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "EOSHIFT"); + } + + if (arraysize == 0) + return; + + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + 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--) + { + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + + 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 probably 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_8 (gfc_array_char * const restrict, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, const char * const restrict, + const GFC_INTEGER_8 * const restrict); +export_proto(eoshift1_8); + +void +eoshift1_8 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_8 * const restrict pwhich) +{ + eoshift1 (ret, array, h, pbound, pwhich, "\0", 1); +} + + +void eoshift1_8_char (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const char * const restrict, + const GFC_INTEGER_8 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_8_char); + +void +eoshift1_8_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + eoshift1 (ret, array, h, pbound, pwhich, " ", 1); +} + + +void eoshift1_8_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const char * const restrict, + const GFC_INTEGER_8 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift1_8_char4); + +void +eoshift1_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const char * const restrict pbound, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift1 (ret, array, h, pbound, pwhich, + (const char *) &space, sizeof (gfc_char4_t)); +} + +#endif diff --git a/libgfortran/generated/eoshift3_16.c b/libgfortran/generated/eoshift3_16.c new file mode 100644 index 000000000..95772e9a8 --- /dev/null +++ b/libgfortran/generated/eoshift3_16.c @@ -0,0 +1,336 @@ +/* Implementation of the EOSHIFT intrinsic + Copyright 2002, 2005, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +static void +eoshift3 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_16 * const restrict pwhich, + const char * filler, index_type filler_len) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char * restrict 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; + index_type size; + index_type arraysize; + 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; + + arraysize = size0 ((array_t *) array); + size = GFC_DESCRIPTOR_SIZE(array); + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + if (ret->data == NULL) + { + int i; + + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) + * GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + + } + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + ret->data = internal_malloc_size (1); + + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "EOSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "EOSHIFT"); + } + + if (arraysize == 0) + return; + + extent[0] = 1; + count[0] = 0; + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + if (bound) + bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n); + 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--) + { + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + + 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 probably 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 restrict, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_16 *); +export_proto(eoshift3_16); + +void +eoshift3_16 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_16 * const restrict pwhich) +{ + eoshift3 (ret, array, h, bound, pwhich, "\0", 1); +} + + +extern void eoshift3_16_char (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_16 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_16_char); + +void +eoshift3_16_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + eoshift3 (ret, array, h, bound, pwhich, " ", 1); +} + + +extern void eoshift3_16_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i16 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_16 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_16_char4); + +void +eoshift3_16_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i16 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_16 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, + (const char *) &space, sizeof (gfc_char4_t)); +} + +#endif diff --git a/libgfortran/generated/eoshift3_4.c b/libgfortran/generated/eoshift3_4.c new file mode 100644 index 000000000..04cbd9f03 --- /dev/null +++ b/libgfortran/generated/eoshift3_4.c @@ -0,0 +1,336 @@ +/* Implementation of the EOSHIFT intrinsic + Copyright 2002, 2005, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +static void +eoshift3 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_4 * const restrict pwhich, + const char * filler, index_type filler_len) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char * restrict 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_4 *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; + index_type size; + index_type arraysize; + int which; + GFC_INTEGER_4 sh; + GFC_INTEGER_4 delta; + + /* The compiler cannot figure out that these are set, initialize + them to avoid warnings. */ + len = 0; + soffset = 0; + roffset = 0; + + arraysize = size0 ((array_t *) array); + size = GFC_DESCRIPTOR_SIZE(array); + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + if (ret->data == NULL) + { + int i; + + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) + * GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + + } + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + ret->data = internal_malloc_size (1); + + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "EOSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "EOSHIFT"); + } + + if (arraysize == 0) + return; + + extent[0] = 1; + count[0] = 0; + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + if (bound) + bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n); + 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--) + { + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + + 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 probably 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_4 (gfc_array_char * const restrict, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_4 *); +export_proto(eoshift3_4); + +void +eoshift3_4 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_4 * const restrict pwhich) +{ + eoshift3 (ret, array, h, bound, pwhich, "\0", 1); +} + + +extern void eoshift3_4_char (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_4 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_4_char); + +void +eoshift3_4_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + eoshift3 (ret, array, h, bound, pwhich, " ", 1); +} + + +extern void eoshift3_4_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i4 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_4 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_4_char4); + +void +eoshift3_4_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i4 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_4 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, + (const char *) &space, sizeof (gfc_char4_t)); +} + +#endif diff --git a/libgfortran/generated/eoshift3_8.c b/libgfortran/generated/eoshift3_8.c new file mode 100644 index 000000000..f2b5a8a50 --- /dev/null +++ b/libgfortran/generated/eoshift3_8.c @@ -0,0 +1,336 @@ +/* Implementation of the EOSHIFT intrinsic + Copyright 2002, 2005, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +static void +eoshift3 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_8 * const restrict pwhich, + const char * filler, index_type filler_len) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + char * restrict 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_8 *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; + index_type size; + index_type arraysize; + int which; + GFC_INTEGER_8 sh; + GFC_INTEGER_8 delta; + + /* The compiler cannot figure out that these are set, initialize + them to avoid warnings. */ + len = 0; + soffset = 0; + roffset = 0; + + arraysize = size0 ((array_t *) array); + size = GFC_DESCRIPTOR_SIZE(array); + + if (pwhich) + which = *pwhich - 1; + else + which = 0; + + if (ret->data == NULL) + { + int i; + + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + index_type ub, str; + + ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1; + + if (i == 0) + str = 1; + else + str = GFC_DESCRIPTOR_EXTENT(ret,i-1) + * GFC_DESCRIPTOR_STRIDE(ret,i-1); + + GFC_DIMENSION_SET(ret->dim[i], 0, ub, str); + + } + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + ret->data = internal_malloc_size (1); + + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_equal_extents ((array_t *) ret, (array_t *) array, + "return value", "EOSHIFT"); + } + + if (unlikely (compile_options.bounds_check)) + { + bounds_reduced_extents ((array_t *) h, (array_t *) array, which, + "SHIFT argument", "EOSHIFT"); + } + + if (arraysize == 0) + return; + + extent[0] = 1; + count[0] = 0; + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + if (roffset == 0) + roffset = size; + soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + if (soffset == 0) + soffset = size; + len = GFC_DESCRIPTOR_EXTENT(array,dim); + } + else + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim); + rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim); + sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim); + + hstride[n] = GFC_DESCRIPTOR_STRIDE(h,n); + if (bound) + bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n); + 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--) + { + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size; i += filler_len) + memcpy (&dest[i], filler, filler_len); + + 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 probably 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_8 (gfc_array_char * const restrict, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_8 *); +export_proto(eoshift3_8); + +void +eoshift3_8 (gfc_array_char * const restrict ret, + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_8 * const restrict pwhich) +{ + eoshift3 (ret, array, h, bound, pwhich, "\0", 1); +} + + +extern void eoshift3_8_char (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_8 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_8_char); + +void +eoshift3_8_char (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + eoshift3 (ret, array, h, bound, pwhich, " ", 1); +} + + +extern void eoshift3_8_char4 (gfc_array_char * const restrict, + GFC_INTEGER_4, + const gfc_array_char * const restrict, + const gfc_array_i8 * const restrict, + const gfc_array_char * const restrict, + const GFC_INTEGER_8 * const restrict, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(eoshift3_8_char4); + +void +eoshift3_8_char4 (gfc_array_char * const restrict ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char * const restrict array, + const gfc_array_i8 * const restrict h, + const gfc_array_char * const restrict bound, + const GFC_INTEGER_8 * const restrict pwhich, + GFC_INTEGER_4 array_length __attribute__((unused)), + GFC_INTEGER_4 bound_length __attribute__((unused))) +{ + static const gfc_char4_t space = (unsigned char) ' '; + eoshift3 (ret, array, h, bound, pwhich, + (const char *) &space, sizeof (gfc_char4_t)); +} + +#endif diff --git a/libgfortran/generated/exponent_r10.c b/libgfortran/generated/exponent_r10.c new file mode 100644 index 000000000..a33451f0c --- /dev/null +++ b/libgfortran/generated/exponent_r10.c @@ -0,0 +1,45 @@ +/* Implementation of the EXPONENT intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## l + +#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; + MATHFUNC(frexp) (s, &ret); + return ret; +} + +#endif diff --git a/libgfortran/generated/exponent_r16.c b/libgfortran/generated/exponent_r16.c new file mode 100644 index 000000000..f05aad255 --- /dev/null +++ b/libgfortran/generated/exponent_r16.c @@ -0,0 +1,49 @@ +/* Implementation of the EXPONENT intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#if defined(GFC_REAL_16_IS_FLOAT128) +#define MATHFUNC(funcname) funcname ## q +#else +#define MATHFUNC(funcname) funcname ## l +#endif + +#if defined (HAVE_GFC_REAL_16) && (defined(GFC_REAL_16_IS_FLOAT128) || 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; + MATHFUNC(frexp) (s, &ret); + return ret; +} + +#endif diff --git a/libgfortran/generated/exponent_r4.c b/libgfortran/generated/exponent_r4.c new file mode 100644 index 000000000..02e36020d --- /dev/null +++ b/libgfortran/generated/exponent_r4.c @@ -0,0 +1,45 @@ +/* Implementation of the EXPONENT intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## f + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_FREXPF) + +extern GFC_INTEGER_4 exponent_r4 (GFC_REAL_4 s); +export_proto(exponent_r4); + +GFC_INTEGER_4 +exponent_r4 (GFC_REAL_4 s) +{ + int ret; + MATHFUNC(frexp) (s, &ret); + return ret; +} + +#endif diff --git a/libgfortran/generated/exponent_r8.c b/libgfortran/generated/exponent_r8.c new file mode 100644 index 000000000..b1633f10c --- /dev/null +++ b/libgfortran/generated/exponent_r8.c @@ -0,0 +1,45 @@ +/* Implementation of the EXPONENT intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_FREXP) + +extern GFC_INTEGER_4 exponent_r8 (GFC_REAL_8 s); +export_proto(exponent_r8); + +GFC_INTEGER_4 +exponent_r8 (GFC_REAL_8 s) +{ + int ret; + MATHFUNC(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 000000000..c883ac943 --- /dev/null +++ b/libgfortran/generated/fraction_r10.c @@ -0,0 +1,44 @@ +/* Implementation of the FRACTION intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## l + +#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 MATHFUNC(frexp) (s, &dummy_exp); +} + +#endif diff --git a/libgfortran/generated/fraction_r16.c b/libgfortran/generated/fraction_r16.c new file mode 100644 index 000000000..df692e1f1 --- /dev/null +++ b/libgfortran/generated/fraction_r16.c @@ -0,0 +1,48 @@ +/* Implementation of the FRACTION intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#if defined(GFC_REAL_16_IS_FLOAT128) +#define MATHFUNC(funcname) funcname ## q +#else +#define MATHFUNC(funcname) funcname ## l +#endif + +#if defined (HAVE_GFC_REAL_16) && (defined(GFC_REAL_16_IS_FLOAT128) || 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 MATHFUNC(frexp) (s, &dummy_exp); +} + +#endif diff --git a/libgfortran/generated/fraction_r4.c b/libgfortran/generated/fraction_r4.c new file mode 100644 index 000000000..f8cac78a3 --- /dev/null +++ b/libgfortran/generated/fraction_r4.c @@ -0,0 +1,44 @@ +/* Implementation of the FRACTION intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## f + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_FREXPF) + +extern GFC_REAL_4 fraction_r4 (GFC_REAL_4 s); +export_proto(fraction_r4); + +GFC_REAL_4 +fraction_r4 (GFC_REAL_4 s) +{ + int dummy_exp; + return MATHFUNC(frexp) (s, &dummy_exp); +} + +#endif diff --git a/libgfortran/generated/fraction_r8.c b/libgfortran/generated/fraction_r8.c new file mode 100644 index 000000000..02ac746c6 --- /dev/null +++ b/libgfortran/generated/fraction_r8.c @@ -0,0 +1,44 @@ +/* Implementation of the FRACTION intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_FREXP) + +extern GFC_REAL_8 fraction_r8 (GFC_REAL_8 s); +export_proto(fraction_r8); + +GFC_REAL_8 +fraction_r8 (GFC_REAL_8 s) +{ + int dummy_exp; + return MATHFUNC(frexp) (s, &dummy_exp); +} + +#endif diff --git a/libgfortran/generated/iall_i1.c b/libgfortran/generated/iall_i1.c new file mode 100644 index 000000000..c6bacab6e --- /dev/null +++ b/libgfortran/generated/iall_i1.c @@ -0,0 +1,509 @@ +/* Implementation of the IALL intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + + +extern void iall_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(iall_i1); + +void +iall_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_1 result; + src = base; + { + + result = (GFC_INTEGER_1) -1; + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miall_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miall_i1); + +void +miall_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IALL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IALL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_1 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 probably 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]; + } + } + } +} + + +extern void siall_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siall_i1); + +void +siall_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iall_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IALL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iall_i16.c b/libgfortran/generated/iall_i16.c new file mode 100644 index 000000000..618f33388 --- /dev/null +++ b/libgfortran/generated/iall_i16.c @@ -0,0 +1,509 @@ +/* Implementation of the IALL intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void iall_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(iall_i16); + +void +iall_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + result = (GFC_INTEGER_16) -1; + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miall_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miall_i16); + +void +miall_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IALL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IALL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void siall_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siall_i16); + +void +siall_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iall_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IALL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iall_i2.c b/libgfortran/generated/iall_i2.c new file mode 100644 index 000000000..c90005947 --- /dev/null +++ b/libgfortran/generated/iall_i2.c @@ -0,0 +1,509 @@ +/* Implementation of the IALL intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) + + +extern void iall_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(iall_i2); + +void +iall_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_2 result; + src = base; + { + + result = (GFC_INTEGER_2) -1; + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miall_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miall_i2); + +void +miall_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_2 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IALL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IALL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_2 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 probably 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]; + } + } + } +} + + +extern void siall_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siall_i2); + +void +siall_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iall_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IALL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iall_i4.c b/libgfortran/generated/iall_i4.c new file mode 100644 index 000000000..d5e7dfe3f --- /dev/null +++ b/libgfortran/generated/iall_i4.c @@ -0,0 +1,509 @@ +/* Implementation of the IALL intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void iall_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(iall_i4); + +void +iall_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + result = (GFC_INTEGER_4) -1; + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miall_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miall_i4); + +void +miall_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IALL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IALL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 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 probably 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]; + } + } + } +} + + +extern void siall_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siall_i4); + +void +siall_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iall_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IALL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iall_i8.c b/libgfortran/generated/iall_i8.c new file mode 100644 index 000000000..74ae1b5ed --- /dev/null +++ b/libgfortran/generated/iall_i8.c @@ -0,0 +1,509 @@ +/* Implementation of the IALL intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void iall_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(iall_i8); + +void +iall_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + result = (GFC_INTEGER_8) -1; + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miall_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miall_i8); + +void +miall_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IALL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IALL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IALL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 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 probably 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]; + } + } + } +} + + +extern void siall_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siall_i8); + +void +siall_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iall_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IALL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IALL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iany_i1.c b/libgfortran/generated/iany_i1.c new file mode 100644 index 000000000..e5d7855a7 --- /dev/null +++ b/libgfortran/generated/iany_i1.c @@ -0,0 +1,509 @@ +/* Implementation of the IANY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + + +extern void iany_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(iany_i1); + +void +iany_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_1 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miany_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miany_i1); + +void +miany_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IANY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IANY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_1 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 probably 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]; + } + } + } +} + + +extern void siany_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siany_i1); + +void +siany_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iany_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IANY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iany_i16.c b/libgfortran/generated/iany_i16.c new file mode 100644 index 000000000..20d14d56d --- /dev/null +++ b/libgfortran/generated/iany_i16.c @@ -0,0 +1,509 @@ +/* Implementation of the IANY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void iany_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(iany_i16); + +void +iany_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miany_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miany_i16); + +void +miany_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IANY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IANY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void siany_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siany_i16); + +void +siany_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iany_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IANY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iany_i2.c b/libgfortran/generated/iany_i2.c new file mode 100644 index 000000000..b464c5d5f --- /dev/null +++ b/libgfortran/generated/iany_i2.c @@ -0,0 +1,509 @@ +/* Implementation of the IANY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) + + +extern void iany_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(iany_i2); + +void +iany_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_2 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miany_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miany_i2); + +void +miany_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_2 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IANY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IANY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_2 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 probably 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]; + } + } + } +} + + +extern void siany_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siany_i2); + +void +siany_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iany_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IANY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iany_i4.c b/libgfortran/generated/iany_i4.c new file mode 100644 index 000000000..3e202820d --- /dev/null +++ b/libgfortran/generated/iany_i4.c @@ -0,0 +1,509 @@ +/* Implementation of the IANY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void iany_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(iany_i4); + +void +iany_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miany_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miany_i4); + +void +miany_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IANY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IANY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 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 probably 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]; + } + } + } +} + + +extern void siany_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siany_i4); + +void +siany_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iany_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IANY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iany_i8.c b/libgfortran/generated/iany_i8.c new file mode 100644 index 000000000..8c89e4d28 --- /dev/null +++ b/libgfortran/generated/iany_i8.c @@ -0,0 +1,509 @@ +/* Implementation of the IANY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void iany_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(iany_i8); + +void +iany_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miany_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miany_i8); + +void +miany_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IANY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IANY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IANY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 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 probably 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]; + } + } + } +} + + +extern void siany_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siany_i8); + +void +siany_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iany_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IANY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IANY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/in_pack_c10.c b/libgfortran/generated/in_pack_c10.c new file mode 100644 index 000000000..97ce9d1ea --- /dev/null +++ b/libgfortran/generated/in_pack_c10.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#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 * restrict dest; + GFC_COMPLEX_10 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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 probably 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 000000000..74e3cb67d --- /dev/null +++ b/libgfortran/generated/in_pack_c16.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#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 * restrict dest; + GFC_COMPLEX_16 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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 probably 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 new file mode 100644 index 000000000..ae52bc689 --- /dev/null +++ b/libgfortran/generated/in_pack_c4.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_COMPLEX_4 * +internal_pack_c4 (gfc_array_c4 * 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_4 *src; + GFC_COMPLEX_4 * restrict dest; + GFC_COMPLEX_4 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_4 *)internal_malloc_size (ssize * sizeof (GFC_COMPLEX_4)); + 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 probably 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_c8.c b/libgfortran/generated/in_pack_c8.c new file mode 100644 index 000000000..142ad99cd --- /dev/null +++ b/libgfortran/generated/in_pack_c8.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_COMPLEX_8 * +internal_pack_c8 (gfc_array_c8 * 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_8 *src; + GFC_COMPLEX_8 * restrict dest; + GFC_COMPLEX_8 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_8 *)internal_malloc_size (ssize * sizeof (GFC_COMPLEX_8)); + 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 probably 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_i1.c b/libgfortran/generated/in_pack_i1.c new file mode 100644 index 000000000..dc26c1af6 --- /dev/null +++ b/libgfortran/generated/in_pack_i1.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_INTEGER_1 * +internal_pack_1 (gfc_array_i1 * 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_1 *src; + GFC_INTEGER_1 * restrict dest; + GFC_INTEGER_1 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_1 *)internal_malloc_size (ssize * sizeof (GFC_INTEGER_1)); + 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 probably 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_i16.c b/libgfortran/generated/in_pack_i16.c new file mode 100644 index 000000000..32ce3a4ea --- /dev/null +++ b/libgfortran/generated/in_pack_i16.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#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 * restrict dest; + GFC_INTEGER_16 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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 probably 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_i2.c b/libgfortran/generated/in_pack_i2.c new file mode 100644 index 000000000..3c39f8e61 --- /dev/null +++ b/libgfortran/generated/in_pack_i2.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_INTEGER_2 * +internal_pack_2 (gfc_array_i2 * 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_2 *src; + GFC_INTEGER_2 * restrict dest; + GFC_INTEGER_2 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_2 *)internal_malloc_size (ssize * sizeof (GFC_INTEGER_2)); + 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 probably 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 new file mode 100644 index 000000000..4cd7dba47 --- /dev/null +++ b/libgfortran/generated/in_pack_i4.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_INTEGER_4 * +internal_pack_4 (gfc_array_i4 * 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_4 *src; + GFC_INTEGER_4 * restrict dest; + GFC_INTEGER_4 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_4 *)internal_malloc_size (ssize * sizeof (GFC_INTEGER_4)); + 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 probably 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_i8.c b/libgfortran/generated/in_pack_i8.c new file mode 100644 index 000000000..17acc684f --- /dev/null +++ b/libgfortran/generated/in_pack_i8.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_INTEGER_8 * +internal_pack_8 (gfc_array_i8 * 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_8 *src; + GFC_INTEGER_8 * restrict dest; + GFC_INTEGER_8 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_8 *)internal_malloc_size (ssize * sizeof (GFC_INTEGER_8)); + 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 probably 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_r10.c b/libgfortran/generated/in_pack_r10.c new file mode 100644 index 000000000..557ccc2aa --- /dev/null +++ b/libgfortran/generated/in_pack_r10.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_REAL_10 * +internal_pack_r10 (gfc_array_r10 * 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_REAL_10 *src; + GFC_REAL_10 * restrict dest; + GFC_REAL_10 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_REAL_10 *)internal_malloc_size (ssize * sizeof (GFC_REAL_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 probably 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_r16.c b/libgfortran/generated/in_pack_r16.c new file mode 100644 index 000000000..b737cc7d2 --- /dev/null +++ b/libgfortran/generated/in_pack_r16.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_REAL_16 * +internal_pack_r16 (gfc_array_r16 * 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_REAL_16 *src; + GFC_REAL_16 * restrict dest; + GFC_REAL_16 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_REAL_16 *)internal_malloc_size (ssize * sizeof (GFC_REAL_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 probably 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_r4.c b/libgfortran/generated/in_pack_r4.c new file mode 100644 index 000000000..68a7e5a0d --- /dev/null +++ b/libgfortran/generated/in_pack_r4.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_REAL_4 * +internal_pack_r4 (gfc_array_r4 * 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_REAL_4 *src; + GFC_REAL_4 * restrict dest; + GFC_REAL_4 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_REAL_4 *)internal_malloc_size (ssize * sizeof (GFC_REAL_4)); + 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 probably 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_r8.c b/libgfortran/generated/in_pack_r8.c new file mode 100644 index 000000000..1453f86b5 --- /dev/null +++ b/libgfortran/generated/in_pack_r8.c @@ -0,0 +1,119 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +/* Allocates a block of memory with internal_malloc if the array needs + repacking. */ + +GFC_REAL_8 * +internal_pack_r8 (gfc_array_r8 * 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_REAL_8 *src; + GFC_REAL_8 * restrict dest; + GFC_REAL_8 *destptr; + int n; + int packed; + + /* TODO: Investigate how we can figure out if this is a temporary + since the stride=0 thing has been removed from the frontend. */ + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + 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_REAL_8 *)internal_malloc_size (ssize * sizeof (GFC_REAL_8)); + 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 probably 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_unpack_c10.c b/libgfortran/generated/in_unpack_c10.c new file mode 100644 index 000000000..bcac6e7a5 --- /dev/null +++ b/libgfortran/generated/in_unpack_c10.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#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 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + 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 probably 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 000000000..1d09a8006 --- /dev/null +++ b/libgfortran/generated/in_unpack_c16.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#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 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + 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 probably 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 new file mode 100644 index 000000000..9ad8a3310 --- /dev/null +++ b/libgfortran/generated/in_unpack_c4.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +void +internal_unpack_c4 (gfc_array_c4 * d, const GFC_COMPLEX_4 * 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_4 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_COMPLEX_4)); + 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 probably 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_c8.c b/libgfortran/generated/in_unpack_c8.c new file mode 100644 index 000000000..6adae640e --- /dev/null +++ b/libgfortran/generated/in_unpack_c8.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +void +internal_unpack_c8 (gfc_array_c8 * d, const GFC_COMPLEX_8 * 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_8 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_COMPLEX_8)); + 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 probably 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_i1.c b/libgfortran/generated/in_unpack_i1.c new file mode 100644 index 000000000..e632816c9 --- /dev/null +++ b/libgfortran/generated/in_unpack_i1.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + +void +internal_unpack_1 (gfc_array_i1 * d, const GFC_INTEGER_1 * 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_1 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_INTEGER_1)); + 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 probably 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_i16.c b/libgfortran/generated/in_unpack_i16.c new file mode 100644 index 000000000..c7199207e --- /dev/null +++ b/libgfortran/generated/in_unpack_i16.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#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 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + 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 probably 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_i2.c b/libgfortran/generated/in_unpack_i2.c new file mode 100644 index 000000000..ec0c1c3ac --- /dev/null +++ b/libgfortran/generated/in_unpack_i2.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + +void +internal_unpack_2 (gfc_array_i2 * d, const GFC_INTEGER_2 * 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_2 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_INTEGER_2)); + 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 probably 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 new file mode 100644 index 000000000..ce5d29df7 --- /dev/null +++ b/libgfortran/generated/in_unpack_i4.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +void +internal_unpack_4 (gfc_array_i4 * d, const GFC_INTEGER_4 * 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_4 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_INTEGER_4)); + 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 probably 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_i8.c b/libgfortran/generated/in_unpack_i8.c new file mode 100644 index 000000000..347f0116c --- /dev/null +++ b/libgfortran/generated/in_unpack_i8.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +void +internal_unpack_8 (gfc_array_i8 * d, const GFC_INTEGER_8 * 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_8 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_INTEGER_8)); + 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 probably 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_r10.c b/libgfortran/generated/in_unpack_r10.c new file mode 100644 index 000000000..aa5f08eb2 --- /dev/null +++ b/libgfortran/generated/in_unpack_r10.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +void +internal_unpack_r10 (gfc_array_r10 * d, const GFC_REAL_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_REAL_10 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_REAL_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 probably 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_r16.c b/libgfortran/generated/in_unpack_r16.c new file mode 100644 index 000000000..0b08228ce --- /dev/null +++ b/libgfortran/generated/in_unpack_r16.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +void +internal_unpack_r16 (gfc_array_r16 * d, const GFC_REAL_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_REAL_16 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_REAL_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 probably 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_r4.c b/libgfortran/generated/in_unpack_r4.c new file mode 100644 index 000000000..f436c8afa --- /dev/null +++ b/libgfortran/generated/in_unpack_r4.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +void +internal_unpack_r4 (gfc_array_r4 * d, const GFC_REAL_4 * 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_REAL_4 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_REAL_4)); + 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 probably 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_r8.c b/libgfortran/generated/in_unpack_r8.c new file mode 100644 index 000000000..76aff2e59 --- /dev/null +++ b/libgfortran/generated/in_unpack_r8.c @@ -0,0 +1,107 @@ +/* Helper function for repacking arrays. + Copyright 2003, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +void +internal_unpack_r8 (gfc_array_r8 * d, const GFC_REAL_8 * 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_REAL_8 * restrict dest; + int n; + + dest = d->data; + if (src == dest || !src) + return; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = GFC_DESCRIPTOR_STRIDE(d,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(d,n); + if (extent[n] <= 0) + return; + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + if (dsize != 0) + { + memcpy (dest, src, dsize * sizeof (GFC_REAL_8)); + 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 probably 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/iparity_i1.c b/libgfortran/generated/iparity_i1.c new file mode 100644 index 000000000..35c51c04d --- /dev/null +++ b/libgfortran/generated/iparity_i1.c @@ -0,0 +1,509 @@ +/* Implementation of the IPARITY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + + +extern void iparity_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(iparity_i1); + +void +iparity_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_1 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miparity_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miparity_i1); + +void +miparity_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IPARITY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IPARITY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_1 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 probably 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]; + } + } + } +} + + +extern void siparity_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siparity_i1); + +void +siparity_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iparity_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IPARITY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iparity_i16.c b/libgfortran/generated/iparity_i16.c new file mode 100644 index 000000000..608fe224a --- /dev/null +++ b/libgfortran/generated/iparity_i16.c @@ -0,0 +1,509 @@ +/* Implementation of the IPARITY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void iparity_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(iparity_i16); + +void +iparity_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miparity_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miparity_i16); + +void +miparity_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IPARITY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IPARITY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void siparity_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siparity_i16); + +void +siparity_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iparity_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IPARITY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iparity_i2.c b/libgfortran/generated/iparity_i2.c new file mode 100644 index 000000000..a1e465c5c --- /dev/null +++ b/libgfortran/generated/iparity_i2.c @@ -0,0 +1,509 @@ +/* Implementation of the IPARITY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) + + +extern void iparity_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(iparity_i2); + +void +iparity_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_2 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miparity_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miparity_i2); + +void +miparity_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_2 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IPARITY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IPARITY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_2 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 probably 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]; + } + } + } +} + + +extern void siparity_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siparity_i2); + +void +siparity_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iparity_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IPARITY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iparity_i4.c b/libgfortran/generated/iparity_i4.c new file mode 100644 index 000000000..e4a492cbf --- /dev/null +++ b/libgfortran/generated/iparity_i4.c @@ -0,0 +1,509 @@ +/* Implementation of the IPARITY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void iparity_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(iparity_i4); + +void +iparity_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miparity_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miparity_i4); + +void +miparity_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IPARITY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IPARITY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 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 probably 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]; + } + } + } +} + + +extern void siparity_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siparity_i4); + +void +siparity_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iparity_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IPARITY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/iparity_i8.c b/libgfortran/generated/iparity_i8.c new file mode 100644 index 000000000..b3997518c --- /dev/null +++ b/libgfortran/generated/iparity_i8.c @@ -0,0 +1,509 @@ +/* Implementation of the IPARITY intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void iparity_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(iparity_i8); + +void +iparity_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void miparity_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(miparity_i8); + +void +miparity_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in IPARITY intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "IPARITY"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "IPARITY"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 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 probably 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]; + } + } + } +} + + +extern void siparity_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(siparity_i8); + +void +siparity_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + iparity_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " IPARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " IPARITY intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_c10.c b/libgfortran/generated/matmul_c10.c new file mode 100644 index 000000000..c54c78ed4 --- /dev/null +++ b/libgfortran/generated/matmul_c10.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_COMPLEX_10 *, const GFC_COMPLEX_10 *, + const int *, const GFC_COMPLEX_10 *, const int *, + const GFC_COMPLEX_10 *, GFC_COMPLEX_10 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_c10 (gfc_array_c10 * const restrict retarray, + gfc_array_c10 * const restrict a, gfc_array_c10 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_c10); + +void +matmul_c10 (gfc_array_c10 * const restrict retarray, + gfc_array_c10 * const restrict a, gfc_array_c10 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_COMPLEX_10 * restrict abase; + const GFC_COMPLEX_10 * restrict bbase; + GFC_COMPLEX_10 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_10) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_COMPLEX_10 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_COMPLEX_10 * restrict bbase_y; + GFC_COMPLEX_10 * restrict dest_y; + const GFC_COMPLEX_10 * restrict abase_n; + GFC_COMPLEX_10 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_COMPLEX_10) * xcount * ycount)); + 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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_COMPLEX_10 *restrict abase_x; + const GFC_COMPLEX_10 *restrict bbase_y; + GFC_COMPLEX_10 *restrict dest_y; + GFC_COMPLEX_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_10) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_COMPLEX_10 *restrict bbase_y; + GFC_COMPLEX_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_10) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + 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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_COMPLEX_10 *restrict bbase_y; + GFC_COMPLEX_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_10) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_COMPLEX_10 *restrict abase_x; + const GFC_COMPLEX_10 *restrict bbase_y; + GFC_COMPLEX_10 *restrict dest_y; + GFC_COMPLEX_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_10) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_c16.c b/libgfortran/generated/matmul_c16.c new file mode 100644 index 000000000..880c0e127 --- /dev/null +++ b/libgfortran/generated/matmul_c16.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_COMPLEX_16 *, const GFC_COMPLEX_16 *, + const int *, const GFC_COMPLEX_16 *, const int *, + const GFC_COMPLEX_16 *, GFC_COMPLEX_16 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_c16 (gfc_array_c16 * const restrict retarray, + gfc_array_c16 * const restrict a, gfc_array_c16 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_c16); + +void +matmul_c16 (gfc_array_c16 * const restrict retarray, + gfc_array_c16 * const restrict a, gfc_array_c16 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_COMPLEX_16 * restrict abase; + const GFC_COMPLEX_16 * restrict bbase; + GFC_COMPLEX_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_16) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_COMPLEX_16 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_COMPLEX_16 * restrict bbase_y; + GFC_COMPLEX_16 * restrict dest_y; + const GFC_COMPLEX_16 * restrict abase_n; + GFC_COMPLEX_16 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_COMPLEX_16) * xcount * ycount)); + 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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_COMPLEX_16 *restrict abase_x; + const GFC_COMPLEX_16 *restrict bbase_y; + GFC_COMPLEX_16 *restrict dest_y; + GFC_COMPLEX_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_COMPLEX_16 *restrict bbase_y; + GFC_COMPLEX_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + 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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_COMPLEX_16 *restrict bbase_y; + GFC_COMPLEX_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_COMPLEX_16 *restrict abase_x; + const GFC_COMPLEX_16 *restrict bbase_y; + GFC_COMPLEX_16 *restrict dest_y; + GFC_COMPLEX_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_c4.c b/libgfortran/generated/matmul_c4.c new file mode 100644 index 000000000..020033a77 --- /dev/null +++ b/libgfortran/generated/matmul_c4.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_COMPLEX_4 *, const GFC_COMPLEX_4 *, + const int *, const GFC_COMPLEX_4 *, const int *, + const GFC_COMPLEX_4 *, GFC_COMPLEX_4 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_c4 (gfc_array_c4 * const restrict retarray, + gfc_array_c4 * const restrict a, gfc_array_c4 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_c4); + +void +matmul_c4 (gfc_array_c4 * const restrict retarray, + gfc_array_c4 * const restrict a, gfc_array_c4 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_COMPLEX_4 * restrict abase; + const GFC_COMPLEX_4 * restrict bbase; + GFC_COMPLEX_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_4) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_COMPLEX_4 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_COMPLEX_4 * restrict bbase_y; + GFC_COMPLEX_4 * restrict dest_y; + const GFC_COMPLEX_4 * restrict abase_n; + GFC_COMPLEX_4 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_COMPLEX_4) * xcount * ycount)); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_COMPLEX_4)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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_COMPLEX_4 *restrict abase_x; + const GFC_COMPLEX_4 *restrict bbase_y; + GFC_COMPLEX_4 *restrict dest_y; + GFC_COMPLEX_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_COMPLEX_4 *restrict bbase_y; + GFC_COMPLEX_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_COMPLEX_4)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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_COMPLEX_4 *restrict bbase_y; + GFC_COMPLEX_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_COMPLEX_4 *restrict abase_x; + const GFC_COMPLEX_4 *restrict bbase_y; + GFC_COMPLEX_4 *restrict dest_y; + GFC_COMPLEX_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_c8.c b/libgfortran/generated/matmul_c8.c new file mode 100644 index 000000000..1522dcd5a --- /dev/null +++ b/libgfortran/generated/matmul_c8.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_COMPLEX_8 *, const GFC_COMPLEX_8 *, + const int *, const GFC_COMPLEX_8 *, const int *, + const GFC_COMPLEX_8 *, GFC_COMPLEX_8 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_c8 (gfc_array_c8 * const restrict retarray, + gfc_array_c8 * const restrict a, gfc_array_c8 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_c8); + +void +matmul_c8 (gfc_array_c8 * const restrict retarray, + gfc_array_c8 * const restrict a, gfc_array_c8 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_COMPLEX_8 * restrict abase; + const GFC_COMPLEX_8 * restrict bbase; + GFC_COMPLEX_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_COMPLEX_8) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_COMPLEX_8 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_COMPLEX_8 * restrict bbase_y; + GFC_COMPLEX_8 * restrict dest_y; + const GFC_COMPLEX_8 * restrict abase_n; + GFC_COMPLEX_8 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_COMPLEX_8) * xcount * ycount)); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_COMPLEX_8)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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_COMPLEX_8 *restrict abase_x; + const GFC_COMPLEX_8 *restrict bbase_y; + GFC_COMPLEX_8 *restrict dest_y; + GFC_COMPLEX_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_COMPLEX_8 *restrict bbase_y; + GFC_COMPLEX_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_COMPLEX_8)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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_COMPLEX_8 *restrict bbase_y; + GFC_COMPLEX_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_COMPLEX_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_COMPLEX_8 *restrict abase_x; + const GFC_COMPLEX_8 *restrict bbase_y; + GFC_COMPLEX_8 *restrict dest_y; + GFC_COMPLEX_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_i1.c b/libgfortran/generated/matmul_i1.c new file mode 100644 index 000000000..db5667851 --- /dev/null +++ b/libgfortran/generated/matmul_i1.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_INTEGER_1 *, const GFC_INTEGER_1 *, + const int *, const GFC_INTEGER_1 *, const int *, + const GFC_INTEGER_1 *, GFC_INTEGER_1 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict a, gfc_array_i1 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_i1); + +void +matmul_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict a, gfc_array_i1 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_INTEGER_1 * restrict abase; + const GFC_INTEGER_1 * restrict bbase; + GFC_INTEGER_1 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_1) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_INTEGER_1 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_INTEGER_1 * restrict bbase_y; + GFC_INTEGER_1 * restrict dest_y; + const GFC_INTEGER_1 * restrict abase_n; + GFC_INTEGER_1 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_INTEGER_1) * xcount * ycount)); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_INTEGER_1)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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_INTEGER_1 *restrict abase_x; + const GFC_INTEGER_1 *restrict bbase_y; + GFC_INTEGER_1 *restrict dest_y; + GFC_INTEGER_1 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_1) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_INTEGER_1 *restrict bbase_y; + GFC_INTEGER_1 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_1) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_INTEGER_1)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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_INTEGER_1 *restrict bbase_y; + GFC_INTEGER_1 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_1) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_INTEGER_1 *restrict abase_x; + const GFC_INTEGER_1 *restrict bbase_y; + GFC_INTEGER_1 *restrict dest_y; + GFC_INTEGER_1 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_1) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_i16.c b/libgfortran/generated/matmul_i16.c new file mode 100644 index 000000000..f607e27b8 --- /dev/null +++ b/libgfortran/generated/matmul_i16.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_INTEGER_16 *, const GFC_INTEGER_16 *, + const int *, const GFC_INTEGER_16 *, const int *, + const GFC_INTEGER_16 *, GFC_INTEGER_16 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict a, gfc_array_i16 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_i16); + +void +matmul_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict a, gfc_array_i16 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_INTEGER_16 * restrict abase; + const GFC_INTEGER_16 * restrict bbase; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_16) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_INTEGER_16 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_INTEGER_16 * restrict bbase_y; + GFC_INTEGER_16 * restrict dest_y; + const GFC_INTEGER_16 * restrict abase_n; + GFC_INTEGER_16 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_INTEGER_16) * xcount * ycount)); + 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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_INTEGER_16 *restrict abase_x; + const GFC_INTEGER_16 *restrict bbase_y; + GFC_INTEGER_16 *restrict dest_y; + GFC_INTEGER_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_INTEGER_16 *restrict bbase_y; + GFC_INTEGER_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + 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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_INTEGER_16 *restrict bbase_y; + GFC_INTEGER_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_INTEGER_16 *restrict abase_x; + const GFC_INTEGER_16 *restrict bbase_y; + GFC_INTEGER_16 *restrict dest_y; + GFC_INTEGER_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_i2.c b/libgfortran/generated/matmul_i2.c new file mode 100644 index 000000000..58e340b77 --- /dev/null +++ b/libgfortran/generated/matmul_i2.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_INTEGER_2 *, const GFC_INTEGER_2 *, + const int *, const GFC_INTEGER_2 *, const int *, + const GFC_INTEGER_2 *, GFC_INTEGER_2 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict a, gfc_array_i2 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_i2); + +void +matmul_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict a, gfc_array_i2 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_INTEGER_2 * restrict abase; + const GFC_INTEGER_2 * restrict bbase; + GFC_INTEGER_2 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_2) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_INTEGER_2 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_INTEGER_2 * restrict bbase_y; + GFC_INTEGER_2 * restrict dest_y; + const GFC_INTEGER_2 * restrict abase_n; + GFC_INTEGER_2 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_INTEGER_2) * xcount * ycount)); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_INTEGER_2)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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_INTEGER_2 *restrict abase_x; + const GFC_INTEGER_2 *restrict bbase_y; + GFC_INTEGER_2 *restrict dest_y; + GFC_INTEGER_2 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_2) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_INTEGER_2 *restrict bbase_y; + GFC_INTEGER_2 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_2) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_INTEGER_2)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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_INTEGER_2 *restrict bbase_y; + GFC_INTEGER_2 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_2) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_INTEGER_2 *restrict abase_x; + const GFC_INTEGER_2 *restrict bbase_y; + GFC_INTEGER_2 *restrict dest_y; + GFC_INTEGER_2 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_2) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_i4.c b/libgfortran/generated/matmul_i4.c new file mode 100644 index 000000000..46ed493d0 --- /dev/null +++ b/libgfortran/generated/matmul_i4.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_INTEGER_4 *, const GFC_INTEGER_4 *, + const int *, const GFC_INTEGER_4 *, const int *, + const GFC_INTEGER_4 *, GFC_INTEGER_4 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict a, gfc_array_i4 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_i4); + +void +matmul_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict a, gfc_array_i4 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_INTEGER_4 * restrict abase; + const GFC_INTEGER_4 * restrict bbase; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_4) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_INTEGER_4 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_INTEGER_4 * restrict bbase_y; + GFC_INTEGER_4 * restrict dest_y; + const GFC_INTEGER_4 * restrict abase_n; + GFC_INTEGER_4 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_INTEGER_4) * xcount * ycount)); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_INTEGER_4)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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_INTEGER_4 *restrict abase_x; + const GFC_INTEGER_4 *restrict bbase_y; + GFC_INTEGER_4 *restrict dest_y; + GFC_INTEGER_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_INTEGER_4 *restrict bbase_y; + GFC_INTEGER_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_INTEGER_4)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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_INTEGER_4 *restrict bbase_y; + GFC_INTEGER_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_INTEGER_4 *restrict abase_x; + const GFC_INTEGER_4 *restrict bbase_y; + GFC_INTEGER_4 *restrict dest_y; + GFC_INTEGER_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_i8.c b/libgfortran/generated/matmul_i8.c new file mode 100644 index 000000000..54ffe6248 --- /dev/null +++ b/libgfortran/generated/matmul_i8.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_INTEGER_8 *, const GFC_INTEGER_8 *, + const int *, const GFC_INTEGER_8 *, const int *, + const GFC_INTEGER_8 *, GFC_INTEGER_8 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict a, gfc_array_i8 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_i8); + +void +matmul_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict a, gfc_array_i8 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_INTEGER_8 * restrict abase; + const GFC_INTEGER_8 * restrict bbase; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_INTEGER_8) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_INTEGER_8 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_INTEGER_8 * restrict bbase_y; + GFC_INTEGER_8 * restrict dest_y; + const GFC_INTEGER_8 * restrict abase_n; + GFC_INTEGER_8 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_INTEGER_8) * xcount * ycount)); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_INTEGER_8)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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_INTEGER_8 *restrict abase_x; + const GFC_INTEGER_8 *restrict bbase_y; + GFC_INTEGER_8 *restrict dest_y; + GFC_INTEGER_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_INTEGER_8 *restrict bbase_y; + GFC_INTEGER_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_INTEGER_8)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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_INTEGER_8 *restrict bbase_y; + GFC_INTEGER_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_INTEGER_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_INTEGER_8 *restrict abase_x; + const GFC_INTEGER_8 *restrict bbase_y; + GFC_INTEGER_8 *restrict dest_y; + GFC_INTEGER_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_l16.c b/libgfortran/generated/matmul_l16.c new file mode 100644 index 000000000..5fbeeb7da --- /dev/null +++ b/libgfortran/generated/matmul_l16.c @@ -0,0 +1,239 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#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 * const restrict, + gfc_array_l1 * const restrict, gfc_array_l1 * const restrict); +export_proto(matmul_l16); + +void +matmul_l16 (gfc_array_l16 * const restrict retarray, + gfc_array_l1 * const restrict a, gfc_array_l1 * const restrict b) +{ + const GFC_LOGICAL_1 * restrict abase; + const GFC_LOGICAL_1 * restrict bbase; + GFC_LOGICAL_16 * restrict 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; + int a_kind; + int b_kind; + + const GFC_LOGICAL_1 * restrict pa; + const GFC_LOGICAL_1 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_LOGICAL_16) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + abase = a->data; + a_kind = GFC_DESCRIPTOR_SIZE (a); + + if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || a_kind == 16 +#endif + ) + abase = GFOR_POINTER_TO_L1 (abase, a_kind); + else + internal_error (NULL, "Funny sized logical array"); + + bbase = b->data; + b_kind = GFC_DESCRIPTOR_SIZE (b); + + if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || b_kind == 16 +#endif + ) + bbase = GFOR_POINTER_TO_L1 (bbase, b_kind); + else + internal_error (NULL, "Funny sized logical array"); + + dest = retarray->data; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = rxstride; + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + /* If we have rank 1 parameters, zero the absent stride, and set the size to + one. */ + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + astride = GFC_DESCRIPTOR_STRIDE_BYTES(a,0); + count = GFC_DESCRIPTOR_EXTENT(a,0); + xstride = 0; + rxstride = 0; + xcount = 1; + } + else + { + astride = GFC_DESCRIPTOR_STRIDE_BYTES(a,1); + count = GFC_DESCRIPTOR_EXTENT(a,1); + xstride = GFC_DESCRIPTOR_STRIDE_BYTES(a,0); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + bstride = GFC_DESCRIPTOR_STRIDE_BYTES(b,0); + assert(count == GFC_DESCRIPTOR_EXTENT(b,0)); + ystride = 0; + rystride = 0; + ycount = 1; + } + else + { + bstride = GFC_DESCRIPTOR_STRIDE_BYTES(b,0); + assert(count == GFC_DESCRIPTOR_EXTENT(b,0)); + ystride = GFC_DESCRIPTOR_STRIDE_BYTES(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + 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 new file mode 100644 index 000000000..19ca9f1e5 --- /dev/null +++ b/libgfortran/generated/matmul_l4.c @@ -0,0 +1,239 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#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. */ + +extern void matmul_l4 (gfc_array_l4 * const restrict, + gfc_array_l1 * const restrict, gfc_array_l1 * const restrict); +export_proto(matmul_l4); + +void +matmul_l4 (gfc_array_l4 * const restrict retarray, + gfc_array_l1 * const restrict a, gfc_array_l1 * const restrict b) +{ + const GFC_LOGICAL_1 * restrict abase; + const GFC_LOGICAL_1 * restrict bbase; + GFC_LOGICAL_4 * restrict 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; + int a_kind; + int b_kind; + + const GFC_LOGICAL_1 * restrict pa; + const GFC_LOGICAL_1 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_LOGICAL_4) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + abase = a->data; + a_kind = GFC_DESCRIPTOR_SIZE (a); + + if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || a_kind == 16 +#endif + ) + abase = GFOR_POINTER_TO_L1 (abase, a_kind); + else + internal_error (NULL, "Funny sized logical array"); + + bbase = b->data; + b_kind = GFC_DESCRIPTOR_SIZE (b); + + if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || b_kind == 16 +#endif + ) + bbase = GFOR_POINTER_TO_L1 (bbase, b_kind); + else + internal_error (NULL, "Funny sized logical array"); + + dest = retarray->data; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = rxstride; + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + /* If we have rank 1 parameters, zero the absent stride, and set the size to + one. */ + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + astride = GFC_DESCRIPTOR_STRIDE_BYTES(a,0); + count = GFC_DESCRIPTOR_EXTENT(a,0); + xstride = 0; + rxstride = 0; + xcount = 1; + } + else + { + astride = GFC_DESCRIPTOR_STRIDE_BYTES(a,1); + count = GFC_DESCRIPTOR_EXTENT(a,1); + xstride = GFC_DESCRIPTOR_STRIDE_BYTES(a,0); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + bstride = GFC_DESCRIPTOR_STRIDE_BYTES(b,0); + assert(count == GFC_DESCRIPTOR_EXTENT(b,0)); + ystride = 0; + rystride = 0; + ycount = 1; + } + else + { + bstride = GFC_DESCRIPTOR_STRIDE_BYTES(b,0); + assert(count == GFC_DESCRIPTOR_EXTENT(b,0)); + ystride = GFC_DESCRIPTOR_STRIDE_BYTES(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + 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_l8.c b/libgfortran/generated/matmul_l8.c new file mode 100644 index 000000000..558ed252e --- /dev/null +++ b/libgfortran/generated/matmul_l8.c @@ -0,0 +1,239 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#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. */ + +extern void matmul_l8 (gfc_array_l8 * const restrict, + gfc_array_l1 * const restrict, gfc_array_l1 * const restrict); +export_proto(matmul_l8); + +void +matmul_l8 (gfc_array_l8 * const restrict retarray, + gfc_array_l1 * const restrict a, gfc_array_l1 * const restrict b) +{ + const GFC_LOGICAL_1 * restrict abase; + const GFC_LOGICAL_1 * restrict bbase; + GFC_LOGICAL_8 * restrict 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; + int a_kind; + int b_kind; + + const GFC_LOGICAL_1 * restrict pa; + const GFC_LOGICAL_1 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_LOGICAL_8) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + abase = a->data; + a_kind = GFC_DESCRIPTOR_SIZE (a); + + if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || a_kind == 16 +#endif + ) + abase = GFOR_POINTER_TO_L1 (abase, a_kind); + else + internal_error (NULL, "Funny sized logical array"); + + bbase = b->data; + b_kind = GFC_DESCRIPTOR_SIZE (b); + + if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || b_kind == 16 +#endif + ) + bbase = GFOR_POINTER_TO_L1 (bbase, b_kind); + else + internal_error (NULL, "Funny sized logical array"); + + dest = retarray->data; + + + if (GFC_DESCRIPTOR_RANK (retarray) == 1) + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = rxstride; + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + /* If we have rank 1 parameters, zero the absent stride, and set the size to + one. */ + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + astride = GFC_DESCRIPTOR_STRIDE_BYTES(a,0); + count = GFC_DESCRIPTOR_EXTENT(a,0); + xstride = 0; + rxstride = 0; + xcount = 1; + } + else + { + astride = GFC_DESCRIPTOR_STRIDE_BYTES(a,1); + count = GFC_DESCRIPTOR_EXTENT(a,1); + xstride = GFC_DESCRIPTOR_STRIDE_BYTES(a,0); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + bstride = GFC_DESCRIPTOR_STRIDE_BYTES(b,0); + assert(count == GFC_DESCRIPTOR_EXTENT(b,0)); + ystride = 0; + rystride = 0; + ycount = 1; + } + else + { + bstride = GFC_DESCRIPTOR_STRIDE_BYTES(b,0); + assert(count == GFC_DESCRIPTOR_EXTENT(b,0)); + ystride = GFC_DESCRIPTOR_STRIDE_BYTES(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + 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_r10.c b/libgfortran/generated/matmul_r10.c new file mode 100644 index 000000000..8e325549c --- /dev/null +++ b/libgfortran/generated/matmul_r10.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_REAL_10 *, const GFC_REAL_10 *, + const int *, const GFC_REAL_10 *, const int *, + const GFC_REAL_10 *, GFC_REAL_10 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict a, gfc_array_r10 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_r10); + +void +matmul_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict a, gfc_array_r10 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_REAL_10 * restrict abase; + const GFC_REAL_10 * restrict bbase; + GFC_REAL_10 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_10) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_REAL_10 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_REAL_10 * restrict bbase_y; + GFC_REAL_10 * restrict dest_y; + const GFC_REAL_10 * restrict abase_n; + GFC_REAL_10 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_REAL_10) * xcount * ycount)); + 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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_REAL_10 *restrict abase_x; + const GFC_REAL_10 *restrict bbase_y; + GFC_REAL_10 *restrict dest_y; + GFC_REAL_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_10) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_REAL_10 *restrict bbase_y; + GFC_REAL_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_10) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + 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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_REAL_10 *restrict bbase_y; + GFC_REAL_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_10) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_REAL_10 *restrict abase_x; + const GFC_REAL_10 *restrict bbase_y; + GFC_REAL_10 *restrict dest_y; + GFC_REAL_10 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_10) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_r16.c b/libgfortran/generated/matmul_r16.c new file mode 100644 index 000000000..c11553180 --- /dev/null +++ b/libgfortran/generated/matmul_r16.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_REAL_16 *, const GFC_REAL_16 *, + const int *, const GFC_REAL_16 *, const int *, + const GFC_REAL_16 *, GFC_REAL_16 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict a, gfc_array_r16 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_r16); + +void +matmul_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict a, gfc_array_r16 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_REAL_16 * restrict abase; + const GFC_REAL_16 * restrict bbase; + GFC_REAL_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_16) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_REAL_16 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_REAL_16 * restrict bbase_y; + GFC_REAL_16 * restrict dest_y; + const GFC_REAL_16 * restrict abase_n; + GFC_REAL_16 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_REAL_16) * xcount * ycount)); + 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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_REAL_16 *restrict abase_x; + const GFC_REAL_16 *restrict bbase_y; + GFC_REAL_16 *restrict dest_y; + GFC_REAL_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_REAL_16 *restrict bbase_y; + GFC_REAL_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + 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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_REAL_16 *restrict bbase_y; + GFC_REAL_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_16) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_REAL_16 *restrict abase_x; + const GFC_REAL_16 *restrict bbase_y; + GFC_REAL_16 *restrict dest_y; + GFC_REAL_16 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_r4.c b/libgfortran/generated/matmul_r4.c new file mode 100644 index 000000000..54208725d --- /dev/null +++ b/libgfortran/generated/matmul_r4.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_REAL_4 *, const GFC_REAL_4 *, + const int *, const GFC_REAL_4 *, const int *, + const GFC_REAL_4 *, GFC_REAL_4 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict a, gfc_array_r4 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_r4); + +void +matmul_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict a, gfc_array_r4 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_REAL_4 * restrict abase; + const GFC_REAL_4 * restrict bbase; + GFC_REAL_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_4) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_REAL_4 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_REAL_4 * restrict bbase_y; + GFC_REAL_4 * restrict dest_y; + const GFC_REAL_4 * restrict abase_n; + GFC_REAL_4 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_REAL_4) * xcount * ycount)); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_REAL_4)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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_REAL_4 *restrict abase_x; + const GFC_REAL_4 *restrict bbase_y; + GFC_REAL_4 *restrict dest_y; + GFC_REAL_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_REAL_4 *restrict bbase_y; + GFC_REAL_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_REAL_4)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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_REAL_4 *restrict bbase_y; + GFC_REAL_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_4) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_REAL_4 *restrict abase_x; + const GFC_REAL_4 *restrict bbase_y; + GFC_REAL_4 *restrict dest_y; + GFC_REAL_4 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/matmul_r8.c b/libgfortran/generated/matmul_r8.c new file mode 100644 index 000000000..72ad1fd58 --- /dev/null +++ b/libgfortran/generated/matmul_r8.c @@ -0,0 +1,376 @@ +/* Implementation of the MATMUL intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be + passed to us by the front-end, in which case we'll call it for large + matrices. */ + +typedef void (*blas_call)(const char *, const char *, const int *, const int *, + const int *, const GFC_REAL_8 *, const GFC_REAL_8 *, + const int *, const GFC_REAL_8 *, const int *, + const GFC_REAL_8 *, GFC_REAL_8 *, const int *, + int, int); + +/* The order of loops is different in the case of plain matrix + multiplication C=MATMUL(A,B), and in the frequent special case where + the argument A is the temporary result of a TRANSPOSE intrinsic: + C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by + looking at their strides. + + The equivalent Fortran pseudo-code is: + + DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) + IF (.NOT.IS_TRANSPOSED(A)) THEN + 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) + ELSE + DO J=1,N + DO I=1,M + S = 0 + DO K=1,COUNT + S = S+A(I,K)*B(K,J) + C(I,J) = S + ENDIF +*/ + +/* If try_blas is set to a nonzero value, then the matmul function will + see if there is a way to perform the matrix multiplication by a call + to the BLAS gemm function. */ + +extern void matmul_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict a, gfc_array_r8 * const restrict b, int try_blas, + int blas_limit, blas_call gemm); +export_proto(matmul_r8); + +void +matmul_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict a, gfc_array_r8 * const restrict b, int try_blas, + int blas_limit, blas_call gemm) +{ + const GFC_REAL_8 * restrict abase; + const GFC_REAL_8 * restrict bbase; + GFC_REAL_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, 1); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + } + else + { + GFC_DIMENSION_SET(retarray->dim[0], 0, + GFC_DESCRIPTOR_EXTENT(a,0) - 1, 1); + + GFC_DIMENSION_SET(retarray->dim[1], 0, + GFC_DESCRIPTOR_EXTENT(b,1) - 1, + GFC_DESCRIPTOR_EXTENT(retarray,0)); + } + + retarray->data + = internal_malloc_size (sizeof (GFC_REAL_8) * size0 ((array_t *) retarray)); + retarray->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, arg_extent; + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else if (GFC_DESCRIPTOR_RANK (b) == 1) + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic: is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + else + { + arg_extent = GFC_DESCRIPTOR_EXTENT(a,0); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 1:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + + arg_extent = GFC_DESCRIPTOR_EXTENT(b,1); + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,1); + if (arg_extent != ret_extent) + runtime_error ("Incorrect extent in return array in" + " MATMUL intrinsic for dimension 2:" + " is %ld, should be %ld", + (long int) ret_extent, (long int) arg_extent); + } + } + + + 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 = GFC_DESCRIPTOR_STRIDE(retarray,0); + } + else + { + rxstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + rystride = GFC_DESCRIPTOR_STRIDE(retarray,1); + } + + + if (GFC_DESCRIPTOR_RANK (a) == 1) + { + /* Treat it as a a row matrix A[1,count]. */ + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = 1; + + xcount = 1; + count = GFC_DESCRIPTOR_EXTENT(a,0); + } + else + { + axstride = GFC_DESCRIPTOR_STRIDE(a,0); + aystride = GFC_DESCRIPTOR_STRIDE(a,1); + + count = GFC_DESCRIPTOR_EXTENT(a,1); + xcount = GFC_DESCRIPTOR_EXTENT(a,0); + } + + if (count != GFC_DESCRIPTOR_EXTENT(b,0)) + { + if (count > 0 || GFC_DESCRIPTOR_EXTENT(b,0) > 0) + runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); + } + + if (GFC_DESCRIPTOR_RANK (b) == 1) + { + /* Treat it as a column matrix B[count,1] */ + bxstride = GFC_DESCRIPTOR_STRIDE(b,0); + + /* 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 = GFC_DESCRIPTOR_STRIDE(b,0); + bystride = GFC_DESCRIPTOR_STRIDE(b,1); + ycount = GFC_DESCRIPTOR_EXTENT(b,1); + } + + abase = a->data; + bbase = b->data; + dest = retarray->data; + + + /* Now that everything is set up, we're performing the multiplication + itself. */ + +#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) + + if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) + && (bxstride == 1 || bystride == 1) + && (((float) xcount) * ((float) ycount) * ((float) count) + > POW3(blas_limit))) + { + const int m = xcount, n = ycount, k = count, ldc = rystride; + const GFC_REAL_8 one = 1, zero = 0; + const int lda = (axstride == 1) ? aystride : axstride, + ldb = (bxstride == 1) ? bystride : bxstride; + + if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) + { + assert (gemm != NULL); + gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, + &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); + return; + } + } + + if (rxstride == 1 && axstride == 1 && bxstride == 1) + { + const GFC_REAL_8 * restrict bbase_y; + GFC_REAL_8 * restrict dest_y; + const GFC_REAL_8 * restrict abase_n; + GFC_REAL_8 bbase_yn; + + if (rystride == xcount) + memset (dest, 0, (sizeof (GFC_REAL_8) * xcount * ycount)); + else + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x + y*rystride] = (GFC_REAL_8)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 if (rxstride == 1 && aystride == 1 && bxstride == 1) + { + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_REAL_8 *restrict abase_x; + const GFC_REAL_8 *restrict bbase_y; + GFC_REAL_8 *restrict dest_y; + GFC_REAL_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else + { + const GFC_REAL_8 *restrict bbase_y; + GFC_REAL_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; + } + } + } + else if (axstride < aystride) + { + for (y = 0; y < ycount; y++) + for (x = 0; x < xcount; x++) + dest[x*rxstride + y*rystride] = (GFC_REAL_8)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]; + } + else if (GFC_DESCRIPTOR_RANK (a) == 1) + { + const GFC_REAL_8 *restrict bbase_y; + GFC_REAL_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + s = (GFC_REAL_8) 0; + for (n = 0; n < count; n++) + s += abase[n*axstride] * bbase_y[n*bxstride]; + dest[y*rxstride] = s; + } + } + else + { + const GFC_REAL_8 *restrict abase_x; + const GFC_REAL_8 *restrict bbase_y; + GFC_REAL_8 *restrict dest_y; + GFC_REAL_8 s; + + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n*aystride] * bbase_y[n*bxstride]; + dest_y[x*rxstride] = s; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc0_16_i1.c b/libgfortran/generated/maxloc0_16_i1.c new file mode 100644 index 000000000..5649018db --- /dev/null +++ b/libgfortran/generated/maxloc0_16_i1.c @@ -0,0 +1,383 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array); +export_proto(maxloc0_16_i1); + +void +maxloc0_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_1 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_1 maxval; +#if defined(GFC_INTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_1_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_i1); + +void +mmaxloc0_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_1 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_i1); + +void +smaxloc0_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_i1 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array); +export_proto(maxloc0_16_i16); + +void +maxloc0_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_16 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_i16); + +void +mmaxloc0_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_16 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_i16); + +void +smaxloc0_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_i16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array); +export_proto(maxloc0_16_i2); + +void +maxloc0_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_2 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_2 maxval; +#if defined(GFC_INTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_2_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_i2); + +void +mmaxloc0_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_2 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_i2); + +void +smaxloc0_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_i2 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array); +export_proto(maxloc0_16_i4); + +void +maxloc0_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_4 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_i4); + +void +mmaxloc0_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_4 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_i4); + +void +smaxloc0_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_i4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array); +export_proto(maxloc0_16_i8); + +void +maxloc0_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_8 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_i8); + +void +mmaxloc0_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_8 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_i8); + +void +smaxloc0_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_i8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array); +export_proto(maxloc0_16_r10); + +void +maxloc0_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_10 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_10_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_10_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_r10); + +void +mmaxloc0_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_10 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_10 maxval; + int fast = 0; + +#if defined(GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_10_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_r10); + +void +smaxloc0_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_r10 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array); +export_proto(maxloc0_16_r16); + +void +maxloc0_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_16 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_r16); + +void +mmaxloc0_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_16 maxval; + int fast = 0; + +#if defined(GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_r16); + +void +smaxloc0_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_r16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array); +export_proto(maxloc0_16_r4); + +void +maxloc0_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_4 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_r4); + +void +mmaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_4 maxval; + int fast = 0; + +#if defined(GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_r4); + +void +smaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_r4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array); +export_proto(maxloc0_16_r8); + +void +maxloc0_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_8 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_16_r8); + +void +mmaxloc0_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_8 maxval; + int fast = 0; + +#if defined(GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_16_r8); + +void +smaxloc0_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + maxloc0_16_r8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array); +export_proto(maxloc0_4_i1); + +void +maxloc0_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_1 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_1 maxval; +#if defined(GFC_INTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_1_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_i1); + +void +mmaxloc0_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_1 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_i1); + +void +smaxloc0_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_i1 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array); +export_proto(maxloc0_4_i16); + +void +maxloc0_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_16 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_i16); + +void +mmaxloc0_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_16 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_i16); + +void +smaxloc0_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_i16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array); +export_proto(maxloc0_4_i2); + +void +maxloc0_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_2 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_2 maxval; +#if defined(GFC_INTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_2_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_i2); + +void +mmaxloc0_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_2 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_i2); + +void +smaxloc0_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_i2 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array); +export_proto(maxloc0_4_i4); + +void +maxloc0_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_4 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_i4); + +void +mmaxloc0_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_4 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_i4); + +void +smaxloc0_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_i4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array); +export_proto(maxloc0_4_i8); + +void +maxloc0_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_8 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_i8); + +void +mmaxloc0_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_8 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_i8); + +void +smaxloc0_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_i8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array); +export_proto(maxloc0_4_r10); + +void +maxloc0_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_10 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_10_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_10_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_r10); + +void +mmaxloc0_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_10 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_10 maxval; + int fast = 0; + +#if defined(GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_10_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_r10); + +void +smaxloc0_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_r10 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array); +export_proto(maxloc0_4_r16); + +void +maxloc0_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_16 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_r16); + +void +mmaxloc0_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_16 maxval; + int fast = 0; + +#if defined(GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_r16); + +void +smaxloc0_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_r16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array); +export_proto(maxloc0_4_r4); + +void +maxloc0_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_4 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_r4); + +void +mmaxloc0_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_4 maxval; + int fast = 0; + +#if defined(GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_r4); + +void +smaxloc0_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_r4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array); +export_proto(maxloc0_4_r8); + +void +maxloc0_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_8 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_4_r8); + +void +mmaxloc0_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_8 maxval; + int fast = 0; + +#if defined(GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_4_r8); + +void +smaxloc0_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + maxloc0_4_r8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array); +export_proto(maxloc0_8_i1); + +void +maxloc0_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_1 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_1 maxval; +#if defined(GFC_INTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_1_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_i1); + +void +mmaxloc0_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_1 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_i1); + +void +smaxloc0_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_i1 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array); +export_proto(maxloc0_8_i16); + +void +maxloc0_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_16 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_i16); + +void +mmaxloc0_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_16 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_i16); + +void +smaxloc0_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_i16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array); +export_proto(maxloc0_8_i2); + +void +maxloc0_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_2 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_2 maxval; +#if defined(GFC_INTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_2_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_i2); + +void +mmaxloc0_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_2 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_i2); + +void +smaxloc0_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_i2 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array); +export_proto(maxloc0_8_i4); + +void +maxloc0_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_4 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_i4); + +void +mmaxloc0_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_4 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_i4); + +void +smaxloc0_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_i4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array); +export_proto(maxloc0_8_i8); + +void +maxloc0_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_8 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_i8); + +void +mmaxloc0_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_8 maxval; + int fast = 0; + +#if defined(GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_i8); + +void +smaxloc0_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_i8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array); +export_proto(maxloc0_8_r10); + +void +maxloc0_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_10 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_10_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_10_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_r10); + +void +mmaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_10 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_10 maxval; + int fast = 0; + +#if defined(GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_10_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_r10); + +void +smaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_r10 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array); +export_proto(maxloc0_8_r16); + +void +maxloc0_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_16 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_r16); + +void +mmaxloc0_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_16 maxval; + int fast = 0; + +#if defined(GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_r16); + +void +smaxloc0_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_r16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array); +export_proto(maxloc0_8_r4); + +void +maxloc0_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_4 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_r4); + +void +mmaxloc0_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_4 maxval; + int fast = 0; + +#if defined(GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_r4); + +void +smaxloc0_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_r4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array); +export_proto(maxloc0_8_r8); + +void +maxloc0_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_8 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base > maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mmaxloc0_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mmaxloc0_8_r8); + +void +mmaxloc0_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_8 maxval; + int fast = 0; + +#if defined(GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, GFC_LOGICAL_4 *); +export_proto(smaxloc0_8_r8); + +void +smaxloc0_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + maxloc0_8_r8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_i1); + +void +maxloc1_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_1 maxval; +#if defined (GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_i1); + +void +mmaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_1 maxval; +#if defined (GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif +#if defined (GFC_INTEGER_1_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_i1); + +void +smaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_i16.c b/libgfortran/generated/maxloc1_16_i16.c new file mode 100644 index 000000000..d6819aa71 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_i16.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_i16); + +void +maxloc1_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_16 maxval; +#if defined (GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_i16); + +void +mmaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 maxval; +#if defined (GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif +#if defined (GFC_INTEGER_16_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_i16); + +void +smaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_i2.c b/libgfortran/generated/maxloc1_16_i2.c new file mode 100644 index 000000000..691d03486 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_i2.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_i2); + +void +maxloc1_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_2 maxval; +#if defined (GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_i2); + +void +mmaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_2 maxval; +#if defined (GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif +#if defined (GFC_INTEGER_2_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_i2); + +void +smaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..1e5b87cab --- /dev/null +++ b/libgfortran/generated/maxloc1_16_i4.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_i4); + +void +maxloc1_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_4 maxval; +#if defined (GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_i4); + +void +mmaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_4 maxval; +#if defined (GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif +#if defined (GFC_INTEGER_4_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_i4); + +void +smaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..c6a73d833 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_i8.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_i8); + +void +maxloc1_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_8 maxval; +#if defined (GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_i8); + +void +mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_8 maxval; +#if defined (GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif +#if defined (GFC_INTEGER_8_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_i8); + +void +smaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..d954000c8 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_r10.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_r10); + +void +maxloc1_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_10 maxval; +#if defined (GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_10_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_r10); + +void +mmaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 maxval; +#if defined (GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif +#if defined (GFC_REAL_10_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_10_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_REAL_10_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_r10); + +void +smaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..4ecb78418 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_r16.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_r16); + +void +maxloc1_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_16 maxval; +#if defined (GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_16_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_r16); + +void +mmaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 maxval; +#if defined (GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif +#if defined (GFC_REAL_16_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_REAL_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_r16); + +void +smaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..e5cd29156 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_r4.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_r4); + +void +maxloc1_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_4 maxval; +#if defined (GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_4_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_r4); + +void +mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_4 maxval; +#if defined (GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif +#if defined (GFC_REAL_4_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_REAL_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_r4); + +void +smaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..2d209d786 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_r8.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc1_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(maxloc1_16_r8); + +void +maxloc1_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_8 maxval; +#if defined (GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_8_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_16_r8); + +void +mmaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_8 maxval; +#if defined (GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif +#if defined (GFC_REAL_8_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_REAL_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_16_r8); + +void +smaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_16_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_i1.c b/libgfortran/generated/maxloc1_4_i1.c new file mode 100644 index 000000000..efd695807 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_i1.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_i1); + +void +maxloc1_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_1 maxval; +#if defined (GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_i1); + +void +mmaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_1 maxval; +#if defined (GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif +#if defined (GFC_INTEGER_1_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_i1); + +void +smaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..71850fcf8 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_i16.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_i16); + +void +maxloc1_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_16 maxval; +#if defined (GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_i16); + +void +mmaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 maxval; +#if defined (GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif +#if defined (GFC_INTEGER_16_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_i16); + +void +smaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_i2.c b/libgfortran/generated/maxloc1_4_i2.c new file mode 100644 index 000000000..d825039e8 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_i2.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_i2); + +void +maxloc1_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_2 maxval; +#if defined (GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_i2); + +void +mmaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_2 maxval; +#if defined (GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif +#if defined (GFC_INTEGER_2_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_i2); + +void +smaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_i4.c b/libgfortran/generated/maxloc1_4_i4.c new file mode 100644 index 000000000..f70b5aa10 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_i4.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_i4); + +void +maxloc1_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_4 maxval; +#if defined (GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_i4); + +void +mmaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_4 maxval; +#if defined (GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif +#if defined (GFC_INTEGER_4_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_i4); + +void +smaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_i8.c b/libgfortran/generated/maxloc1_4_i8.c new file mode 100644 index 000000000..cda4a99ca --- /dev/null +++ b/libgfortran/generated/maxloc1_4_i8.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_i8); + +void +maxloc1_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_8 maxval; +#if defined (GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_i8); + +void +mmaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_8 maxval; +#if defined (GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif +#if defined (GFC_INTEGER_8_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_i8); + +void +smaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_r10.c b/libgfortran/generated/maxloc1_4_r10.c new file mode 100644 index 000000000..7901a4b15 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_r10.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_r10); + +void +maxloc1_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_10 maxval; +#if defined (GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_10_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_r10); + +void +mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 maxval; +#if defined (GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif +#if defined (GFC_REAL_10_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_10_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_REAL_10_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_r10); + +void +smaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..f06d7b2bb --- /dev/null +++ b/libgfortran/generated/maxloc1_4_r16.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_r16); + +void +maxloc1_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_16 maxval; +#if defined (GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_16_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_r16); + +void +mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 maxval; +#if defined (GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif +#if defined (GFC_REAL_16_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_REAL_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_r16); + +void +smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_r4.c b/libgfortran/generated/maxloc1_4_r4.c new file mode 100644 index 000000000..e6837aa61 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_r4.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_r4); + +void +maxloc1_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_4 maxval; +#if defined (GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_4_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_r4); + +void +mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_4 maxval; +#if defined (GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif +#if defined (GFC_REAL_4_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_REAL_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_r4); + +void +smaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_r8.c b/libgfortran/generated/maxloc1_4_r8.c new file mode 100644 index 000000000..26c10c7b9 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_r8.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc1_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(maxloc1_4_r8); + +void +maxloc1_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_8 maxval; +#if defined (GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_8_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_4_r8); + +void +mmaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_8 maxval; +#if defined (GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif +#if defined (GFC_REAL_8_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_REAL_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_4_r8); + +void +smaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_4_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_i1.c b/libgfortran/generated/maxloc1_8_i1.c new file mode 100644 index 000000000..c9dc61020 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_i1.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_i1); + +void +maxloc1_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_1 maxval; +#if defined (GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_i1); + +void +mmaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_1 maxval; +#if defined (GFC_INTEGER_1_INFINITY) + maxval = -GFC_INTEGER_1_INFINITY; +#else + maxval = (-GFC_INTEGER_1_HUGE-1); +#endif +#if defined (GFC_INTEGER_1_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_i1); + +void +smaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_i16.c b/libgfortran/generated/maxloc1_8_i16.c new file mode 100644 index 000000000..7cd62ac3a --- /dev/null +++ b/libgfortran/generated/maxloc1_8_i16.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_i16); + +void +maxloc1_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_16 maxval; +#if defined (GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_i16); + +void +mmaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 maxval; +#if defined (GFC_INTEGER_16_INFINITY) + maxval = -GFC_INTEGER_16_INFINITY; +#else + maxval = (-GFC_INTEGER_16_HUGE-1); +#endif +#if defined (GFC_INTEGER_16_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_i16); + +void +smaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_i2.c b/libgfortran/generated/maxloc1_8_i2.c new file mode 100644 index 000000000..fd0cc2172 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_i2.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_i2); + +void +maxloc1_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_2 maxval; +#if defined (GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_i2); + +void +mmaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_2 maxval; +#if defined (GFC_INTEGER_2_INFINITY) + maxval = -GFC_INTEGER_2_INFINITY; +#else + maxval = (-GFC_INTEGER_2_HUGE-1); +#endif +#if defined (GFC_INTEGER_2_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_i2); + +void +smaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_i4.c b/libgfortran/generated/maxloc1_8_i4.c new file mode 100644 index 000000000..97cd54bb5 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_i4.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_i4); + +void +maxloc1_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_4 maxval; +#if defined (GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_i4); + +void +mmaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_4 maxval; +#if defined (GFC_INTEGER_4_INFINITY) + maxval = -GFC_INTEGER_4_INFINITY; +#else + maxval = (-GFC_INTEGER_4_HUGE-1); +#endif +#if defined (GFC_INTEGER_4_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_i4); + +void +smaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_i8.c b/libgfortran/generated/maxloc1_8_i8.c new file mode 100644 index 000000000..f9c455cb0 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_i8.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_i8); + +void +maxloc1_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_8 maxval; +#if defined (GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_i8); + +void +mmaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_8 maxval; +#if defined (GFC_INTEGER_8_INFINITY) + maxval = -GFC_INTEGER_8_INFINITY; +#else + maxval = (-GFC_INTEGER_8_HUGE-1); +#endif +#if defined (GFC_INTEGER_8_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_i8); + +void +smaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_r10.c b/libgfortran/generated/maxloc1_8_r10.c new file mode 100644 index 000000000..ab1173c6c --- /dev/null +++ b/libgfortran/generated/maxloc1_8_r10.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_r10); + +void +maxloc1_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_10 maxval; +#if defined (GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_10_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_r10); + +void +mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 maxval; +#if defined (GFC_REAL_10_INFINITY) + maxval = -GFC_REAL_10_INFINITY; +#else + maxval = -GFC_REAL_10_HUGE; +#endif +#if defined (GFC_REAL_10_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_10_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_REAL_10_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_r10); + +void +smaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..9a02e1273 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_r16.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_r16); + +void +maxloc1_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_16 maxval; +#if defined (GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_16_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_r16); + +void +mmaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 maxval; +#if defined (GFC_REAL_16_INFINITY) + maxval = -GFC_REAL_16_INFINITY; +#else + maxval = -GFC_REAL_16_HUGE; +#endif +#if defined (GFC_REAL_16_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_REAL_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_r16); + +void +smaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_r4.c b/libgfortran/generated/maxloc1_8_r4.c new file mode 100644 index 000000000..584bdb81f --- /dev/null +++ b/libgfortran/generated/maxloc1_8_r4.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_r4); + +void +maxloc1_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_4 maxval; +#if defined (GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_4_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_r4); + +void +mmaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_4 maxval; +#if defined (GFC_REAL_4_INFINITY) + maxval = -GFC_REAL_4_INFINITY; +#else + maxval = -GFC_REAL_4_HUGE; +#endif +#if defined (GFC_REAL_4_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_REAL_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_r4); + +void +smaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_r8.c b/libgfortran/generated/maxloc1_8_r8.c new file mode 100644 index 000000000..c6f3efd70 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_r8.c @@ -0,0 +1,563 @@ +/* Implementation of the MAXLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc1_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(maxloc1_8_r8); + +void +maxloc1_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_8 maxval; +#if defined (GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_8_QUIET_NAN) + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxloc1_8_r8); + +void +mmaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_8 maxval; +#if defined (GFC_REAL_8_INFINITY) + maxval = -GFC_REAL_8_INFINITY; +#else + maxval = -GFC_REAL_8_HUGE; +#endif +#if defined (GFC_REAL_8_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_REAL_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void smaxloc1_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxloc1_8_r8); + +void +smaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxloc1_8_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_i1.c b/libgfortran/generated/maxval_i1.c new file mode 100644 index 000000000..5b676827d --- /dev/null +++ b/libgfortran/generated/maxval_i1.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + + +extern void maxval_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(maxval_i1); + +void +maxval_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_1 result; + src = base; + { + +#if defined (GFC_INTEGER_1_INFINITY) + result = -GFC_INTEGER_1_INFINITY; +#else + result = (-GFC_INTEGER_1_HUGE-1); +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_1_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_1_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_i1); + +void +mmaxval_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_1 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_1_INFINITY) + result = -GFC_INTEGER_1_INFINITY; +#else + result = (-GFC_INTEGER_1_HUGE-1); +#endif +#if defined (GFC_INTEGER_1_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_1_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_1_INFINITY) || defined (GFC_INTEGER_1_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_1_QUIET_NAN : (-GFC_INTEGER_1_HUGE-1); +#else + result = (-GFC_INTEGER_1_HUGE-1); +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_i1); + +void +smaxval_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_1_HUGE-1); + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_i16.c b/libgfortran/generated/maxval_i16.c new file mode 100644 index 000000000..148319d62 --- /dev/null +++ b/libgfortran/generated/maxval_i16.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxval_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(maxval_i16); + +void +maxval_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + +#if defined (GFC_INTEGER_16_INFINITY) + result = -GFC_INTEGER_16_INFINITY; +#else + result = (-GFC_INTEGER_16_HUGE-1); +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_16_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_16_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_i16); + +void +mmaxval_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_16_INFINITY) + result = -GFC_INTEGER_16_INFINITY; +#else + result = (-GFC_INTEGER_16_HUGE-1); +#endif +#if defined (GFC_INTEGER_16_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_16_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_16_INFINITY) || defined (GFC_INTEGER_16_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_16_QUIET_NAN : (-GFC_INTEGER_16_HUGE-1); +#else + result = (-GFC_INTEGER_16_HUGE-1); +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_i16); + +void +smaxval_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_16_HUGE-1); + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_i2.c b/libgfortran/generated/maxval_i2.c new file mode 100644 index 000000000..f87f3edf3 --- /dev/null +++ b/libgfortran/generated/maxval_i2.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) + + +extern void maxval_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(maxval_i2); + +void +maxval_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_2 result; + src = base; + { + +#if defined (GFC_INTEGER_2_INFINITY) + result = -GFC_INTEGER_2_INFINITY; +#else + result = (-GFC_INTEGER_2_HUGE-1); +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_2_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_2_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_i2); + +void +mmaxval_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_2 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_2 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_2_INFINITY) + result = -GFC_INTEGER_2_INFINITY; +#else + result = (-GFC_INTEGER_2_HUGE-1); +#endif +#if defined (GFC_INTEGER_2_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_2_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_2_INFINITY) || defined (GFC_INTEGER_2_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_2_QUIET_NAN : (-GFC_INTEGER_2_HUGE-1); +#else + result = (-GFC_INTEGER_2_HUGE-1); +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_i2); + +void +smaxval_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_2_HUGE-1); + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_i4.c b/libgfortran/generated/maxval_i4.c new file mode 100644 index 000000000..51f2511b4 --- /dev/null +++ b/libgfortran/generated/maxval_i4.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxval_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(maxval_i4); + +void +maxval_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + +#if defined (GFC_INTEGER_4_INFINITY) + result = -GFC_INTEGER_4_INFINITY; +#else + result = (-GFC_INTEGER_4_HUGE-1); +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_4_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_4_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_i4); + +void +mmaxval_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_4_INFINITY) + result = -GFC_INTEGER_4_INFINITY; +#else + result = (-GFC_INTEGER_4_HUGE-1); +#endif +#if defined (GFC_INTEGER_4_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_4_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_4_INFINITY) || defined (GFC_INTEGER_4_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_4_QUIET_NAN : (-GFC_INTEGER_4_HUGE-1); +#else + result = (-GFC_INTEGER_4_HUGE-1); +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_i4); + +void +smaxval_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_4_HUGE-1); + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_i8.c b/libgfortran/generated/maxval_i8.c new file mode 100644 index 000000000..74aca03cf --- /dev/null +++ b/libgfortran/generated/maxval_i8.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxval_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(maxval_i8); + +void +maxval_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + +#if defined (GFC_INTEGER_8_INFINITY) + result = -GFC_INTEGER_8_INFINITY; +#else + result = (-GFC_INTEGER_8_HUGE-1); +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_8_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_8_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_i8); + +void +mmaxval_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_8_INFINITY) + result = -GFC_INTEGER_8_INFINITY; +#else + result = (-GFC_INTEGER_8_HUGE-1); +#endif +#if defined (GFC_INTEGER_8_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = (-GFC_INTEGER_8_HUGE-1); + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_8_INFINITY) || defined (GFC_INTEGER_8_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_8_QUIET_NAN : (-GFC_INTEGER_8_HUGE-1); +#else + result = (-GFC_INTEGER_8_HUGE-1); +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_i8); + +void +smaxval_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = (-GFC_INTEGER_8_HUGE-1); + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_r10.c b/libgfortran/generated/maxval_r10.c new file mode 100644 index 000000000..3eaaa4c47 --- /dev/null +++ b/libgfortran/generated/maxval_r10.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) + + +extern void maxval_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(maxval_r10); + +void +maxval_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_REAL_10 result; + src = base; + { + +#if defined (GFC_REAL_10_INFINITY) + result = -GFC_REAL_10_INFINITY; +#else + result = -GFC_REAL_10_HUGE; +#endif + if (len <= 0) + *dest = -GFC_REAL_10_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_10_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_REAL_10_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_r10); + +void +mmaxval_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_10 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_REAL_10_INFINITY) + result = -GFC_REAL_10_INFINITY; +#else + result = -GFC_REAL_10_HUGE; +#endif +#if defined (GFC_REAL_10_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = -GFC_REAL_10_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_REAL_10_INFINITY) || defined (GFC_REAL_10_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_REAL_10_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_REAL_10_QUIET_NAN) + result = non_empty_p ? GFC_REAL_10_QUIET_NAN : -GFC_REAL_10_HUGE; +#else + result = -GFC_REAL_10_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_r10); + +void +smaxval_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = -GFC_REAL_10_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_r16.c b/libgfortran/generated/maxval_r16.c new file mode 100644 index 000000000..bc4cf27bb --- /dev/null +++ b/libgfortran/generated/maxval_r16.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) + + +extern void maxval_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(maxval_r16); + +void +maxval_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_REAL_16 result; + src = base; + { + +#if defined (GFC_REAL_16_INFINITY) + result = -GFC_REAL_16_INFINITY; +#else + result = -GFC_REAL_16_HUGE; +#endif + if (len <= 0) + *dest = -GFC_REAL_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_16_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_REAL_16_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_r16); + +void +mmaxval_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_16 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_REAL_16_INFINITY) + result = -GFC_REAL_16_INFINITY; +#else + result = -GFC_REAL_16_HUGE; +#endif +#if defined (GFC_REAL_16_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = -GFC_REAL_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_REAL_16_INFINITY) || defined (GFC_REAL_16_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_REAL_16_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_REAL_16_QUIET_NAN) + result = non_empty_p ? GFC_REAL_16_QUIET_NAN : -GFC_REAL_16_HUGE; +#else + result = -GFC_REAL_16_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_r16); + +void +smaxval_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = -GFC_REAL_16_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_r4.c b/libgfortran/generated/maxval_r4.c new file mode 100644 index 000000000..d7e25ee7a --- /dev/null +++ b/libgfortran/generated/maxval_r4.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) + + +extern void maxval_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(maxval_r4); + +void +maxval_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_REAL_4 result; + src = base; + { + +#if defined (GFC_REAL_4_INFINITY) + result = -GFC_REAL_4_INFINITY; +#else + result = -GFC_REAL_4_HUGE; +#endif + if (len <= 0) + *dest = -GFC_REAL_4_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_4_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_REAL_4_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_r4); + +void +mmaxval_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_4 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_4 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_REAL_4_INFINITY) + result = -GFC_REAL_4_INFINITY; +#else + result = -GFC_REAL_4_HUGE; +#endif +#if defined (GFC_REAL_4_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = -GFC_REAL_4_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_REAL_4_INFINITY) || defined (GFC_REAL_4_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_REAL_4_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_REAL_4_QUIET_NAN) + result = non_empty_p ? GFC_REAL_4_QUIET_NAN : -GFC_REAL_4_HUGE; +#else + result = -GFC_REAL_4_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_r4); + +void +smaxval_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = -GFC_REAL_4_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxval_r8.c b/libgfortran/generated/maxval_r8.c new file mode 100644 index 000000000..21c08e9ef --- /dev/null +++ b/libgfortran/generated/maxval_r8.c @@ -0,0 +1,550 @@ +/* Implementation of the MAXVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) + + +extern void maxval_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(maxval_r8); + +void +maxval_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_REAL_8 result; + src = base; + { + +#if defined (GFC_REAL_8_INFINITY) + result = -GFC_REAL_8_INFINITY; +#else + result = -GFC_REAL_8_HUGE; +#endif + if (len <= 0) + *dest = -GFC_REAL_8_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_8_QUIET_NAN) + if (*src >= result) + break; + } + if (unlikely (n >= len)) + result = GFC_REAL_8_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxval_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mmaxval_r8); + +void +mmaxval_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_8 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_8 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_REAL_8_INFINITY) + result = -GFC_REAL_8_INFINITY; +#else + result = -GFC_REAL_8_HUGE; +#endif +#if defined (GFC_REAL_8_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = -GFC_REAL_8_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_REAL_8_INFINITY) || defined (GFC_REAL_8_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_REAL_8_QUIET_NAN) + non_empty_p = 1; + if (*src >= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_REAL_8_QUIET_NAN) + result = non_empty_p ? GFC_REAL_8_QUIET_NAN : -GFC_REAL_8_HUGE; +#else + result = -GFC_REAL_8_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void smaxval_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(smaxval_r8); + +void +smaxval_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + maxval_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = -GFC_REAL_8_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_16_i1.c b/libgfortran/generated/minloc0_16_i1.c new file mode 100644 index 000000000..2fbd7609d --- /dev/null +++ b/libgfortran/generated/minloc0_16_i1.c @@ -0,0 +1,383 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array); +export_proto(minloc0_16_i1); + +void +minloc0_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_1 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_1 minval; +#if defined(GFC_INTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_1_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_i1); + +void +mminloc0_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_1 minval; + int fast = 0; + +#if defined(GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_i1); + +void +sminloc0_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_i1 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array); +export_proto(minloc0_16_i16); + +void +minloc0_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_16 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_i16); + +void +mminloc0_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_16 minval; + int fast = 0; + +#if defined(GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_i16); + +void +sminloc0_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_i16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array); +export_proto(minloc0_16_i2); + +void +minloc0_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_2 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_2 minval; +#if defined(GFC_INTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_2_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_i2); + +void +mminloc0_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_2 minval; + int fast = 0; + +#if defined(GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_i2); + +void +sminloc0_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_i2 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array); +export_proto(minloc0_16_i4); + +void +minloc0_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_4 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_i4); + +void +mminloc0_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_4 minval; + int fast = 0; + +#if defined(GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_i4); + +void +sminloc0_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_i4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array); +export_proto(minloc0_16_i8); + +void +minloc0_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_8 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_i8); + +void +mminloc0_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_8 minval; + int fast = 0; + +#if defined(GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_i8); + +void +sminloc0_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_i8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array); +export_proto(minloc0_16_r10); + +void +minloc0_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_10 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_10_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_10_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_r10); + +void +mminloc0_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_10 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_10 minval; + int fast = 0; + +#if defined(GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_10_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_r10); + +void +sminloc0_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_r10 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array); +export_proto(minloc0_16_r16); + +void +minloc0_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_16 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_r16); + +void +mminloc0_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_16 minval; + int fast = 0; + +#if defined(GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_r16); + +void +sminloc0_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_r16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array); +export_proto(minloc0_16_r4); + +void +minloc0_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_4 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_r4); + +void +mminloc0_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_4 minval; + int fast = 0; + +#if defined(GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_r4); + +void +sminloc0_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_r4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array); +export_proto(minloc0_16_r8); + +void +minloc0_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_8 *base; + GFC_INTEGER_16 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_16_r8); + +void +mminloc0_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_8 minval; + int fast = 0; + +#if defined(GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_16_r8); + +void +sminloc0_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (*mask) + { + minloc0_16_r8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array); +export_proto(minloc0_4_i1); + +void +minloc0_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_1 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_1 minval; +#if defined(GFC_INTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_1_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_i1); + +void +mminloc0_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_1 minval; + int fast = 0; + +#if defined(GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_i1); + +void +sminloc0_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_i1 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array); +export_proto(minloc0_4_i16); + +void +minloc0_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_16 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_i16); + +void +mminloc0_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_16 minval; + int fast = 0; + +#if defined(GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_i16); + +void +sminloc0_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_i16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array); +export_proto(minloc0_4_i2); + +void +minloc0_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_2 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_2 minval; +#if defined(GFC_INTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_2_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_i2); + +void +mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_2 minval; + int fast = 0; + +#if defined(GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_i2); + +void +sminloc0_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_i2 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array); +export_proto(minloc0_4_i4); + +void +minloc0_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_4 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_i4); + +void +mminloc0_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_4 minval; + int fast = 0; + +#if defined(GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_i4); + +void +sminloc0_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_i4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array); +export_proto(minloc0_4_i8); + +void +minloc0_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_8 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_i8); + +void +mminloc0_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_8 minval; + int fast = 0; + +#if defined(GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_i8); + +void +sminloc0_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_i8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array); +export_proto(minloc0_4_r10); + +void +minloc0_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_10 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_10_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_10_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_r10); + +void +mminloc0_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_10 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_10 minval; + int fast = 0; + +#if defined(GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_10_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_r10); + +void +sminloc0_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_r10 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array); +export_proto(minloc0_4_r16); + +void +minloc0_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_16 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_r16); + +void +mminloc0_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_16 minval; + int fast = 0; + +#if defined(GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_r16); + +void +sminloc0_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_r16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array); +export_proto(minloc0_4_r4); + +void +minloc0_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_4 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_r4); + +void +mminloc0_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_4 minval; + int fast = 0; + +#if defined(GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_r4); + +void +sminloc0_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_r4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array); +export_proto(minloc0_4_r8); + +void +minloc0_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_8 *base; + GFC_INTEGER_4 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_4_r8); + +void +mminloc0_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_8 minval; + int fast = 0; + +#if defined(GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_4_r8); + +void +sminloc0_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (*mask) + { + minloc0_4_r8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array); +export_proto(minloc0_8_i1); + +void +minloc0_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_1 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_1 minval; +#if defined(GFC_INTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_1_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_i1); + +void +mminloc0_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_1 minval; + int fast = 0; + +#if defined(GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_i1); + +void +sminloc0_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_i1 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array); +export_proto(minloc0_8_i16); + +void +minloc0_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_16 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_i16); + +void +mminloc0_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_16 minval; + int fast = 0; + +#if defined(GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_i16); + +void +sminloc0_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_i16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array); +export_proto(minloc0_8_i2); + +void +minloc0_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_2 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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_2 minval; +#if defined(GFC_INTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_2_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_i2); + +void +mminloc0_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_2 minval; + int fast = 0; + +#if defined(GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_i2); + +void +sminloc0_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_i2 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array); +export_proto(minloc0_8_i4); + +void +minloc0_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_4 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_i4); + +void +mminloc0_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_4 minval; + int fast = 0; + +#if defined(GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_i4); + +void +sminloc0_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_i4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array); +export_proto(minloc0_8_i8); + +void +minloc0_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_INTEGER_8 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_INTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_INTEGER_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_i8); + +void +mminloc0_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_INTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_INTEGER_8 minval; + int fast = 0; + +#if defined(GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_INTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_i8); + +void +sminloc0_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_i8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array); +export_proto(minloc0_8_r10); + +void +minloc0_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_10 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_10_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_10_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_r10); + +void +mminloc0_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_10 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_10 minval; + int fast = 0; + +#if defined(GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_10_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_r10); + +void +sminloc0_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_r10 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array); +export_proto(minloc0_8_r16); + +void +minloc0_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_16 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_16_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_r16); + +void +mminloc0_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_16 minval; + int fast = 0; + +#if defined(GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_r16); + +void +sminloc0_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_r16 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array); +export_proto(minloc0_8_r4); + +void +minloc0_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_4 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_4_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_r4); + +void +mminloc0_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_4 minval; + int fast = 0; + +#if defined(GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_r4); + +void +sminloc0_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_r4 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array); +export_proto(minloc0_8_r8); + +void +minloc0_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_REAL_8 *base; + GFC_INTEGER_8 * restrict 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) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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; +#if defined(GFC_REAL_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + +#if defined(GFC_REAL_8_QUIET_NAN) + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { +#endif + if (*base < minval) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void mminloc0_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, gfc_array_l1 * const restrict); +export_proto(mminloc0_8_r8); + +void +mminloc0_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + gfc_array_l1 * const restrict 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; + const GFC_REAL_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->data; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + 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] = 0; + { + + GFC_REAL_8 minval; + int fast = 0; + +#if defined(GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + while (base) + { + do + { + /* Implementation start. */ + + } + while (0); + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_REAL_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else do + { + 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. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* 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 probably 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]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void sminloc0_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, GFC_LOGICAL_4 *); +export_proto(sminloc0_8_r8); + +void +sminloc0_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + GFC_LOGICAL_4 * mask) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (*mask) + { + minloc0_8_r8 (retarray, array); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->data == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->data; + for (n = 0; n + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_i1); + +void +minloc1_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_1 minval; +#if defined (GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_i1); + +void +mminloc1_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_1 minval; +#if defined (GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif +#if defined (GFC_INTEGER_1_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_i1 (gfc_array_i16 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_i1); + +void +sminloc1_16_i1 (gfc_array_i16 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_i16.c b/libgfortran/generated/minloc1_16_i16.c new file mode 100644 index 000000000..3a18e8c36 --- /dev/null +++ b/libgfortran/generated/minloc1_16_i16.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_i16); + +void +minloc1_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_16 minval; +#if defined (GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_i16); + +void +mminloc1_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 minval; +#if defined (GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif +#if defined (GFC_INTEGER_16_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_i16); + +void +sminloc1_16_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_i2.c b/libgfortran/generated/minloc1_16_i2.c new file mode 100644 index 000000000..bc13bee9e --- /dev/null +++ b/libgfortran/generated/minloc1_16_i2.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_i2); + +void +minloc1_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_2 minval; +#if defined (GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_i2); + +void +mminloc1_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_2 minval; +#if defined (GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif +#if defined (GFC_INTEGER_2_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_i2 (gfc_array_i16 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_i2); + +void +sminloc1_16_i2 (gfc_array_i16 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..84d131a7a --- /dev/null +++ b/libgfortran/generated/minloc1_16_i4.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_i4); + +void +minloc1_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_4 minval; +#if defined (GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_i4); + +void +mminloc1_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_4 minval; +#if defined (GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif +#if defined (GFC_INTEGER_4_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_i4 (gfc_array_i16 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_i4); + +void +sminloc1_16_i4 (gfc_array_i16 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..1f3e0549d --- /dev/null +++ b/libgfortran/generated/minloc1_16_i8.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_i8); + +void +minloc1_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_INTEGER_8 minval; +#if defined (GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_i8); + +void +mminloc1_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_8 minval; +#if defined (GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif +#if defined (GFC_INTEGER_8_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_i8 (gfc_array_i16 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_i8); + +void +sminloc1_16_i8 (gfc_array_i16 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..6bda151ae --- /dev/null +++ b/libgfortran/generated/minloc1_16_r10.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_r10); + +void +minloc1_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_10 minval; +#if defined (GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_10_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_r10); + +void +mminloc1_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 minval; +#if defined (GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif +#if defined (GFC_REAL_10_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_10_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_REAL_10_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_r10 (gfc_array_i16 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_r10); + +void +sminloc1_16_r10 (gfc_array_i16 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..c31cf4bcb --- /dev/null +++ b/libgfortran/generated/minloc1_16_r16.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_r16); + +void +minloc1_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_16 minval; +#if defined (GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_16_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_r16); + +void +mminloc1_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 minval; +#if defined (GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif +#if defined (GFC_REAL_16_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_REAL_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_r16 (gfc_array_i16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_r16); + +void +sminloc1_16_r16 (gfc_array_i16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..52ec2b078 --- /dev/null +++ b/libgfortran/generated/minloc1_16_r4.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_r4); + +void +minloc1_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_4 minval; +#if defined (GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_4_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_r4); + +void +mminloc1_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_4 minval; +#if defined (GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif +#if defined (GFC_REAL_4_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_REAL_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_r4 (gfc_array_i16 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_r4); + +void +sminloc1_16_r4 (gfc_array_i16 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..a53ed3452 --- /dev/null +++ b/libgfortran/generated/minloc1_16_r8.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc1_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(minloc1_16_r8); + +void +minloc1_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_REAL_8 minval; +#if defined (GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_8_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_16_r8); + +void +mminloc1_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_REAL_8 minval; +#if defined (GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif +#if defined (GFC_REAL_8_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_REAL_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_16_r8 (gfc_array_i16 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_16_r8); + +void +sminloc1_16_r8 (gfc_array_i16 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_16_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_i1.c b/libgfortran/generated/minloc1_4_i1.c new file mode 100644 index 000000000..e8af36127 --- /dev/null +++ b/libgfortran/generated/minloc1_4_i1.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_i1); + +void +minloc1_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_1 minval; +#if defined (GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_i1); + +void +mminloc1_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_1 minval; +#if defined (GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif +#if defined (GFC_INTEGER_1_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_i1 (gfc_array_i4 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_i1); + +void +sminloc1_4_i1 (gfc_array_i4 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..8d3da2059 --- /dev/null +++ b/libgfortran/generated/minloc1_4_i16.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_i16); + +void +minloc1_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_16 minval; +#if defined (GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_i16); + +void +mminloc1_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 minval; +#if defined (GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif +#if defined (GFC_INTEGER_16_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_i16 (gfc_array_i4 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_i16); + +void +sminloc1_4_i16 (gfc_array_i4 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_i2.c b/libgfortran/generated/minloc1_4_i2.c new file mode 100644 index 000000000..e7f24491f --- /dev/null +++ b/libgfortran/generated/minloc1_4_i2.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_i2); + +void +minloc1_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_2 minval; +#if defined (GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_i2); + +void +mminloc1_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_2 minval; +#if defined (GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif +#if defined (GFC_INTEGER_2_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_i2 (gfc_array_i4 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_i2); + +void +sminloc1_4_i2 (gfc_array_i4 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_i4.c b/libgfortran/generated/minloc1_4_i4.c new file mode 100644 index 000000000..94d45c92d --- /dev/null +++ b/libgfortran/generated/minloc1_4_i4.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_i4); + +void +minloc1_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_4 minval; +#if defined (GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_i4); + +void +mminloc1_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_4 minval; +#if defined (GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif +#if defined (GFC_INTEGER_4_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_i4); + +void +sminloc1_4_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_i8.c b/libgfortran/generated/minloc1_4_i8.c new file mode 100644 index 000000000..fa07bcb87 --- /dev/null +++ b/libgfortran/generated/minloc1_4_i8.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_i8); + +void +minloc1_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_INTEGER_8 minval; +#if defined (GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_i8); + +void +mminloc1_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_8 minval; +#if defined (GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif +#if defined (GFC_INTEGER_8_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_i8 (gfc_array_i4 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_i8); + +void +sminloc1_4_i8 (gfc_array_i4 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_r10.c b/libgfortran/generated/minloc1_4_r10.c new file mode 100644 index 000000000..5cb23a6b6 --- /dev/null +++ b/libgfortran/generated/minloc1_4_r10.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_r10); + +void +minloc1_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_10 minval; +#if defined (GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_10_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_r10); + +void +mminloc1_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 minval; +#if defined (GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif +#if defined (GFC_REAL_10_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_10_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_REAL_10_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_r10 (gfc_array_i4 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_r10); + +void +sminloc1_4_r10 (gfc_array_i4 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..40854a12b --- /dev/null +++ b/libgfortran/generated/minloc1_4_r16.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_r16); + +void +minloc1_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_16 minval; +#if defined (GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_16_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_r16); + +void +mminloc1_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 minval; +#if defined (GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif +#if defined (GFC_REAL_16_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_REAL_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_r16 (gfc_array_i4 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_r16); + +void +sminloc1_4_r16 (gfc_array_i4 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_r4.c b/libgfortran/generated/minloc1_4_r4.c new file mode 100644 index 000000000..4231d180d --- /dev/null +++ b/libgfortran/generated/minloc1_4_r4.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_r4); + +void +minloc1_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_4 minval; +#if defined (GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_4_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_r4); + +void +mminloc1_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_4 minval; +#if defined (GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif +#if defined (GFC_REAL_4_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_REAL_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_r4 (gfc_array_i4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_r4); + +void +sminloc1_4_r4 (gfc_array_i4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_r8.c b/libgfortran/generated/minloc1_4_r8.c new file mode 100644 index 000000000..8e5e5ddc4 --- /dev/null +++ b/libgfortran/generated/minloc1_4_r8.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc1_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(minloc1_4_r8); + +void +minloc1_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_REAL_8 minval; +#if defined (GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_8_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_4_r8); + +void +mminloc1_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_REAL_8 minval; +#if defined (GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif +#if defined (GFC_REAL_8_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_REAL_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_4_r8 (gfc_array_i4 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_4_r8); + +void +sminloc1_4_r8 (gfc_array_i4 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_4_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_i1.c b/libgfortran/generated/minloc1_8_i1.c new file mode 100644 index 000000000..9a54335c8 --- /dev/null +++ b/libgfortran/generated/minloc1_8_i1.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_i1); + +void +minloc1_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_1 minval; +#if defined (GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_i1); + +void +mminloc1_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_1 minval; +#if defined (GFC_INTEGER_1_INFINITY) + minval = GFC_INTEGER_1_INFINITY; +#else + minval = GFC_INTEGER_1_HUGE; +#endif +#if defined (GFC_INTEGER_1_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_i1 (gfc_array_i8 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_i1); + +void +sminloc1_8_i1 (gfc_array_i8 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_i16.c b/libgfortran/generated/minloc1_8_i16.c new file mode 100644 index 000000000..f0b477ebd --- /dev/null +++ b/libgfortran/generated/minloc1_8_i16.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_i16); + +void +minloc1_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_16 minval; +#if defined (GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_i16); + +void +mminloc1_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_16 minval; +#if defined (GFC_INTEGER_16_INFINITY) + minval = GFC_INTEGER_16_INFINITY; +#else + minval = GFC_INTEGER_16_HUGE; +#endif +#if defined (GFC_INTEGER_16_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_i16 (gfc_array_i8 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_i16); + +void +sminloc1_8_i16 (gfc_array_i8 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_i2.c b/libgfortran/generated/minloc1_8_i2.c new file mode 100644 index 000000000..9d3d14ee5 --- /dev/null +++ b/libgfortran/generated/minloc1_8_i2.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_i2); + +void +minloc1_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_2 minval; +#if defined (GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_i2); + +void +mminloc1_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_2 minval; +#if defined (GFC_INTEGER_2_INFINITY) + minval = GFC_INTEGER_2_INFINITY; +#else + minval = GFC_INTEGER_2_HUGE; +#endif +#if defined (GFC_INTEGER_2_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_i2 (gfc_array_i8 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_i2); + +void +sminloc1_8_i2 (gfc_array_i8 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_i4.c b/libgfortran/generated/minloc1_8_i4.c new file mode 100644 index 000000000..edac05ccd --- /dev/null +++ b/libgfortran/generated/minloc1_8_i4.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_i4); + +void +minloc1_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_4 minval; +#if defined (GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_i4); + +void +mminloc1_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_4 minval; +#if defined (GFC_INTEGER_4_INFINITY) + minval = GFC_INTEGER_4_INFINITY; +#else + minval = GFC_INTEGER_4_HUGE; +#endif +#if defined (GFC_INTEGER_4_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_i4 (gfc_array_i8 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_i4); + +void +sminloc1_8_i4 (gfc_array_i8 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_i8.c b/libgfortran/generated/minloc1_8_i8.c new file mode 100644 index 000000000..3c0f44127 --- /dev/null +++ b/libgfortran/generated/minloc1_8_i8.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_i8); + +void +minloc1_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_INTEGER_8 minval; +#if defined (GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_i8); + +void +mminloc1_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_INTEGER_8 minval; +#if defined (GFC_INTEGER_8_INFINITY) + minval = GFC_INTEGER_8_INFINITY; +#else + minval = GFC_INTEGER_8_HUGE; +#endif +#if defined (GFC_INTEGER_8_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_i8); + +void +sminloc1_8_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_r10.c b/libgfortran/generated/minloc1_8_r10.c new file mode 100644 index 000000000..a9239d28c --- /dev/null +++ b/libgfortran/generated/minloc1_8_r10.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_r10); + +void +minloc1_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_10 minval; +#if defined (GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_10_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_r10); + +void +mminloc1_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_10 minval; +#if defined (GFC_REAL_10_INFINITY) + minval = GFC_REAL_10_INFINITY; +#else + minval = GFC_REAL_10_HUGE; +#endif +#if defined (GFC_REAL_10_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_10_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_REAL_10_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_r10 (gfc_array_i8 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_r10); + +void +sminloc1_8_r10 (gfc_array_i8 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[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 000000000..953ada7ef --- /dev/null +++ b/libgfortran/generated/minloc1_8_r16.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_r16); + +void +minloc1_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_16 minval; +#if defined (GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_16_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_r16); + +void +mminloc1_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_16 minval; +#if defined (GFC_REAL_16_INFINITY) + minval = GFC_REAL_16_INFINITY; +#else + minval = GFC_REAL_16_HUGE; +#endif +#if defined (GFC_REAL_16_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_REAL_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_r16 (gfc_array_i8 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_r16); + +void +sminloc1_8_r16 (gfc_array_i8 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_r4.c b/libgfortran/generated/minloc1_8_r4.c new file mode 100644 index 000000000..388200016 --- /dev/null +++ b/libgfortran/generated/minloc1_8_r4.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_r4); + +void +minloc1_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_4 minval; +#if defined (GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_4_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_r4); + +void +mminloc1_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_4 minval; +#if defined (GFC_REAL_4_INFINITY) + minval = GFC_REAL_4_INFINITY; +#else + minval = GFC_REAL_4_HUGE; +#endif +#if defined (GFC_REAL_4_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_REAL_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_r4 (gfc_array_i8 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_r4); + +void +sminloc1_8_r4 (gfc_array_i8 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_r8.c b/libgfortran/generated/minloc1_8_r8.c new file mode 100644 index 000000000..c8d181277 --- /dev/null +++ b/libgfortran/generated/minloc1_8_r8.c @@ -0,0 +1,563 @@ +/* Implementation of the MINLOC intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc1_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(minloc1_8_r8); + +void +minloc1_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_REAL_8 minval; +#if defined (GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_8_QUIET_NAN) + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminloc1_8_r8); + +void +mminloc1_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_REAL_8 minval; +#if defined (GFC_REAL_8_INFINITY) + minval = GFC_REAL_8_INFINITY; +#else + minval = GFC_REAL_8_HUGE; +#endif +#if defined (GFC_REAL_8_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_REAL_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_REAL_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + for (; 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 probably 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]; + } + } + } +} + + +extern void sminloc1_8_r8 (gfc_array_i8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminloc1_8_r8); + +void +sminloc1_8_r8 (gfc_array_i8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minloc1_8_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_i1.c b/libgfortran/generated/minval_i1.c new file mode 100644 index 000000000..d9ee1d754 --- /dev/null +++ b/libgfortran/generated/minval_i1.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + + +extern void minval_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(minval_i1); + +void +minval_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_1 result; + src = base; + { + +#if defined (GFC_INTEGER_1_INFINITY) + result = GFC_INTEGER_1_INFINITY; +#else + result = GFC_INTEGER_1_HUGE; +#endif + if (len <= 0) + *dest = GFC_INTEGER_1_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_1_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_1_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_i1); + +void +mminval_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_1 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_1_INFINITY) + result = GFC_INTEGER_1_INFINITY; +#else + result = GFC_INTEGER_1_HUGE; +#endif +#if defined (GFC_INTEGER_1_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_INTEGER_1_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_1_INFINITY) || defined (GFC_INTEGER_1_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_1_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_1_QUIET_NAN : GFC_INTEGER_1_HUGE; +#else + result = GFC_INTEGER_1_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_i1); + +void +sminval_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_1_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_i16.c b/libgfortran/generated/minval_i16.c new file mode 100644 index 000000000..839454756 --- /dev/null +++ b/libgfortran/generated/minval_i16.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minval_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(minval_i16); + +void +minval_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + +#if defined (GFC_INTEGER_16_INFINITY) + result = GFC_INTEGER_16_INFINITY; +#else + result = GFC_INTEGER_16_HUGE; +#endif + if (len <= 0) + *dest = GFC_INTEGER_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_16_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_16_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_i16); + +void +mminval_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_16_INFINITY) + result = GFC_INTEGER_16_INFINITY; +#else + result = GFC_INTEGER_16_HUGE; +#endif +#if defined (GFC_INTEGER_16_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_INTEGER_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_16_INFINITY) || defined (GFC_INTEGER_16_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_16_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_16_QUIET_NAN : GFC_INTEGER_16_HUGE; +#else + result = GFC_INTEGER_16_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_i16); + +void +sminval_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_16_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_i2.c b/libgfortran/generated/minval_i2.c new file mode 100644 index 000000000..9cffe844d --- /dev/null +++ b/libgfortran/generated/minval_i2.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) + + +extern void minval_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(minval_i2); + +void +minval_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_2 result; + src = base; + { + +#if defined (GFC_INTEGER_2_INFINITY) + result = GFC_INTEGER_2_INFINITY; +#else + result = GFC_INTEGER_2_HUGE; +#endif + if (len <= 0) + *dest = GFC_INTEGER_2_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_2_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_2_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_i2); + +void +mminval_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_2 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_2 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_2_INFINITY) + result = GFC_INTEGER_2_INFINITY; +#else + result = GFC_INTEGER_2_HUGE; +#endif +#if defined (GFC_INTEGER_2_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_INTEGER_2_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_2_INFINITY) || defined (GFC_INTEGER_2_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_2_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_2_QUIET_NAN : GFC_INTEGER_2_HUGE; +#else + result = GFC_INTEGER_2_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_i2); + +void +sminval_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_2_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_i4.c b/libgfortran/generated/minval_i4.c new file mode 100644 index 000000000..993116a83 --- /dev/null +++ b/libgfortran/generated/minval_i4.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void minval_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(minval_i4); + +void +minval_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + +#if defined (GFC_INTEGER_4_INFINITY) + result = GFC_INTEGER_4_INFINITY; +#else + result = GFC_INTEGER_4_HUGE; +#endif + if (len <= 0) + *dest = GFC_INTEGER_4_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_4_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_4_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_i4); + +void +mminval_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_4_INFINITY) + result = GFC_INTEGER_4_INFINITY; +#else + result = GFC_INTEGER_4_HUGE; +#endif +#if defined (GFC_INTEGER_4_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_INTEGER_4_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_4_INFINITY) || defined (GFC_INTEGER_4_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_4_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_4_QUIET_NAN : GFC_INTEGER_4_HUGE; +#else + result = GFC_INTEGER_4_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_i4); + +void +sminval_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_4_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_i8.c b/libgfortran/generated/minval_i8.c new file mode 100644 index 000000000..3a52b4b7e --- /dev/null +++ b/libgfortran/generated/minval_i8.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void minval_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(minval_i8); + +void +minval_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + +#if defined (GFC_INTEGER_8_INFINITY) + result = GFC_INTEGER_8_INFINITY; +#else + result = GFC_INTEGER_8_HUGE; +#endif + if (len <= 0) + *dest = GFC_INTEGER_8_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_INTEGER_8_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_INTEGER_8_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_i8); + +void +mminval_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_INTEGER_8_INFINITY) + result = GFC_INTEGER_8_INFINITY; +#else + result = GFC_INTEGER_8_HUGE; +#endif +#if defined (GFC_INTEGER_8_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_INTEGER_8_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_INTEGER_8_INFINITY) || defined (GFC_INTEGER_8_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_INTEGER_8_QUIET_NAN) + result = non_empty_p ? GFC_INTEGER_8_QUIET_NAN : GFC_INTEGER_8_HUGE; +#else + result = GFC_INTEGER_8_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_i8); + +void +sminval_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_INTEGER_8_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_r10.c b/libgfortran/generated/minval_r10.c new file mode 100644 index 000000000..b490b3bee --- /dev/null +++ b/libgfortran/generated/minval_r10.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) + + +extern void minval_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(minval_r10); + +void +minval_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_REAL_10 result; + src = base; + { + +#if defined (GFC_REAL_10_INFINITY) + result = GFC_REAL_10_INFINITY; +#else + result = GFC_REAL_10_HUGE; +#endif + if (len <= 0) + *dest = GFC_REAL_10_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_10_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_REAL_10_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_r10); + +void +mminval_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_10 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_REAL_10_INFINITY) + result = GFC_REAL_10_INFINITY; +#else + result = GFC_REAL_10_HUGE; +#endif +#if defined (GFC_REAL_10_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_REAL_10_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_REAL_10_INFINITY) || defined (GFC_REAL_10_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_REAL_10_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_REAL_10_QUIET_NAN) + result = non_empty_p ? GFC_REAL_10_QUIET_NAN : GFC_REAL_10_HUGE; +#else + result = GFC_REAL_10_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_r10); + +void +sminval_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_REAL_10_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_r16.c b/libgfortran/generated/minval_r16.c new file mode 100644 index 000000000..701191f40 --- /dev/null +++ b/libgfortran/generated/minval_r16.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) + + +extern void minval_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(minval_r16); + +void +minval_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_REAL_16 result; + src = base; + { + +#if defined (GFC_REAL_16_INFINITY) + result = GFC_REAL_16_INFINITY; +#else + result = GFC_REAL_16_HUGE; +#endif + if (len <= 0) + *dest = GFC_REAL_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_16_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_REAL_16_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_r16); + +void +mminval_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_16 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_REAL_16_INFINITY) + result = GFC_REAL_16_INFINITY; +#else + result = GFC_REAL_16_HUGE; +#endif +#if defined (GFC_REAL_16_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_REAL_16_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_REAL_16_INFINITY) || defined (GFC_REAL_16_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_REAL_16_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_REAL_16_QUIET_NAN) + result = non_empty_p ? GFC_REAL_16_QUIET_NAN : GFC_REAL_16_HUGE; +#else + result = GFC_REAL_16_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_r16); + +void +sminval_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_REAL_16_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_r4.c b/libgfortran/generated/minval_r4.c new file mode 100644 index 000000000..e69376590 --- /dev/null +++ b/libgfortran/generated/minval_r4.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) + + +extern void minval_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(minval_r4); + +void +minval_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_REAL_4 result; + src = base; + { + +#if defined (GFC_REAL_4_INFINITY) + result = GFC_REAL_4_INFINITY; +#else + result = GFC_REAL_4_HUGE; +#endif + if (len <= 0) + *dest = GFC_REAL_4_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_4_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_REAL_4_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_r4); + +void +mminval_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_4 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_4 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_REAL_4_INFINITY) + result = GFC_REAL_4_INFINITY; +#else + result = GFC_REAL_4_HUGE; +#endif +#if defined (GFC_REAL_4_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_REAL_4_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_REAL_4_INFINITY) || defined (GFC_REAL_4_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_REAL_4_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_REAL_4_QUIET_NAN) + result = non_empty_p ? GFC_REAL_4_QUIET_NAN : GFC_REAL_4_HUGE; +#else + result = GFC_REAL_4_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_r4); + +void +sminval_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_REAL_4_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minval_r8.c b/libgfortran/generated/minval_r8.c new file mode 100644 index 000000000..611ee5796 --- /dev/null +++ b/libgfortran/generated/minval_r8.c @@ -0,0 +1,550 @@ +/* Implementation of the MINVAL intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) + + +extern void minval_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(minval_r8); + +void +minval_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_REAL_8 result; + src = base; + { + +#if defined (GFC_REAL_8_INFINITY) + result = GFC_REAL_8_INFINITY; +#else + result = GFC_REAL_8_HUGE; +#endif + if (len <= 0) + *dest = GFC_REAL_8_HUGE; + else + { + for (n = 0; n < len; n++, src += delta) + { + +#if defined (GFC_REAL_8_QUIET_NAN) + if (*src <= result) + break; + } + if (unlikely (n >= len)) + result = GFC_REAL_8_QUIET_NAN; + else for (; n < len; n++, src += delta) + { +#endif + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminval_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mminval_r8); + +void +mminval_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_8 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINVAL intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINVAL"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINVAL"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_8 result; + src = base; + msrc = mbase; + { + +#if defined (GFC_REAL_8_INFINITY) + result = GFC_REAL_8_INFINITY; +#else + result = GFC_REAL_8_HUGE; +#endif +#if defined (GFC_REAL_8_QUIET_NAN) + int non_empty_p = 0; +#endif + if (len <= 0) + *dest = GFC_REAL_8_HUGE; + else + { + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + +#if defined (GFC_REAL_8_INFINITY) || defined (GFC_REAL_8_QUIET_NAN) + if (*msrc) + { +#if defined (GFC_REAL_8_QUIET_NAN) + non_empty_p = 1; + if (*src <= result) +#endif + break; + } + } + if (unlikely (n >= len)) + { +#if defined (GFC_REAL_8_QUIET_NAN) + result = non_empty_p ? GFC_REAL_8_QUIET_NAN : GFC_REAL_8_HUGE; +#else + result = GFC_REAL_8_HUGE; +#endif + } + else for (; n < len; n++, src += delta, msrc += mdelta) + { +#endif + 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 probably 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]; + } + } + } +} + + +extern void sminval_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sminval_r8); + +void +sminval_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + minval_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINVAL intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINVAL intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = GFC_REAL_8_HUGE; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/misc_specifics.F90 b/libgfortran/generated/misc_specifics.F90 new file mode 100644 index 000000000..2df9a23b4 --- /dev/null +++ b/libgfortran/generated/misc_specifics.F90 @@ -0,0 +1,206 @@ +! Copyright 2002, 2007, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook +! +!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 3 of the License, or (at your option) any later version. +! +!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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!. +! +!This file is machine generated. + +#include "config.h" +#include "kinds.inc" + + + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4) +elemental function _gfortran_specific__nint_4_4 (parm) + real (kind=4) , intent (in) :: parm + integer (kind=4) :: _gfortran_specific__nint_4_4 + _gfortran_specific__nint_4_4 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4) +elemental function _gfortran_specific__nint_4_8 (parm) + real (kind=8) , intent (in) :: parm + integer (kind=4) :: _gfortran_specific__nint_4_8 + _gfortran_specific__nint_4_8 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4) +elemental function _gfortran_specific__nint_4_10 (parm) + real (kind=10) , intent (in) :: parm + integer (kind=4) :: _gfortran_specific__nint_4_10 + _gfortran_specific__nint_4_10 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4) +elemental function _gfortran_specific__nint_4_16 (parm) + real (kind=16) , intent (in) :: parm + integer (kind=4) :: _gfortran_specific__nint_4_16 + _gfortran_specific__nint_4_16 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_8) +elemental function _gfortran_specific__nint_8_4 (parm) + real (kind=4) , intent (in) :: parm + integer (kind=8) :: _gfortran_specific__nint_8_4 + _gfortran_specific__nint_8_4 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_8) +elemental function _gfortran_specific__nint_8_8 (parm) + real (kind=8) , intent (in) :: parm + integer (kind=8) :: _gfortran_specific__nint_8_8 + _gfortran_specific__nint_8_8 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8) +elemental function _gfortran_specific__nint_8_10 (parm) + real (kind=10) , intent (in) :: parm + integer (kind=8) :: _gfortran_specific__nint_8_10 + _gfortran_specific__nint_8_10 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8) +elemental function _gfortran_specific__nint_8_16 (parm) + real (kind=16) , intent (in) :: parm + integer (kind=8) :: _gfortran_specific__nint_8_16 + _gfortran_specific__nint_8_16 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16) +elemental function _gfortran_specific__nint_16_4 (parm) + real (kind=4) , intent (in) :: parm + integer (kind=16) :: _gfortran_specific__nint_16_4 + _gfortran_specific__nint_16_4 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_16) +elemental function _gfortran_specific__nint_16_8 (parm) + real (kind=8) , intent (in) :: parm + integer (kind=16) :: _gfortran_specific__nint_16_8 + _gfortran_specific__nint_16_8 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) +elemental function _gfortran_specific__nint_16_10 (parm) + real (kind=10) , intent (in) :: parm + integer (kind=16) :: _gfortran_specific__nint_16_10 + _gfortran_specific__nint_16_10 = nint (parm) +end function +#endif + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16) +elemental function _gfortran_specific__nint_16_16 (parm) + real (kind=16) , intent (in) :: parm + integer (kind=16) :: _gfortran_specific__nint_16_16 + _gfortran_specific__nint_16_16 = nint (parm) +end function +#endif + + + +#if defined (HAVE_GFC_INTEGER_4) +elemental function _gfortran_specific__char_1_i4 (parm) + integer (kind=4) , intent (in) :: parm + character (kind=1,len=1) :: _gfortran_specific__char_1_i4 + _gfortran_specific__char_1_i4 = char (parm, kind=1) +end function +#endif + +#if defined (HAVE_GFC_INTEGER_8) +elemental function _gfortran_specific__char_1_i8 (parm) + integer (kind=8) , intent (in) :: parm + character (kind=1,len=1) :: _gfortran_specific__char_1_i8 + _gfortran_specific__char_1_i8 = char (parm, kind=1) +end function +#endif + +#if defined (HAVE_GFC_INTEGER_16) +elemental function _gfortran_specific__char_1_i16 (parm) + integer (kind=16) , intent (in) :: parm + character (kind=1,len=1) :: _gfortran_specific__char_1_i16 + _gfortran_specific__char_1_i16 = char (parm, kind=1) +end function +#endif + + + +#if defined (HAVE_GFC_INTEGER_4) +elemental function _gfortran_specific__len_1_i4 (parm) + character (kind=1,len=*) , intent (in) :: parm + integer (kind=4) :: _gfortran_specific__len_1_i4 + _gfortran_specific__len_1_i4 = len (parm) +end function +#endif + +#if defined (HAVE_GFC_INTEGER_8) +elemental function _gfortran_specific__len_1_i8 (parm) + character (kind=1,len=*) , intent (in) :: parm + integer (kind=8) :: _gfortran_specific__len_1_i8 + _gfortran_specific__len_1_i8 = len (parm) +end function +#endif + +#if defined (HAVE_GFC_INTEGER_16) +elemental function _gfortran_specific__len_1_i16 (parm) + character (kind=1,len=*) , intent (in) :: parm + integer (kind=16) :: _gfortran_specific__len_1_i16 + _gfortran_specific__len_1_i16 = len (parm) +end function +#endif + + + +#if defined (HAVE_GFC_INTEGER_4) +elemental function _gfortran_specific__index_1_i4 (parm1, parm2) + character (kind=1,len=*) , intent (in) :: parm1, parm2 + integer (kind=4) :: _gfortran_specific__index_1_i4 + _gfortran_specific__index_1_i4 = index (parm1, parm2) +end function +#endif + +#if defined (HAVE_GFC_INTEGER_8) +elemental function _gfortran_specific__index_1_i8 (parm1, parm2) + character (kind=1,len=*) , intent (in) :: parm1, parm2 + integer (kind=8) :: _gfortran_specific__index_1_i8 + _gfortran_specific__index_1_i8 = index (parm1, parm2) +end function +#endif + +#if defined (HAVE_GFC_INTEGER_16) +elemental function _gfortran_specific__index_1_i16 (parm1, parm2) + character (kind=1,len=*) , intent (in) :: parm1, parm2 + integer (kind=16) :: _gfortran_specific__index_1_i16 + _gfortran_specific__index_1_i16 = index (parm1, parm2) +end function +#endif + diff --git a/libgfortran/generated/nearest_r10.c b/libgfortran/generated/nearest_r10.c new file mode 100644 index 000000000..2414bb35d --- /dev/null +++ b/libgfortran/generated/nearest_r10.c @@ -0,0 +1,51 @@ +/* Implementation of the NEAREST intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## l + +#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 = MATHFUNC(copysign) (MATHFUNC(__builtin_inf) (), dir); + if (FLT_EVAL_METHOD != 0) + { + /* ??? Work around glibc bug on x86. */ + volatile GFC_REAL_10 r = MATHFUNC(nextafter) (s, dir); + return r; + } + else + return MATHFUNC(nextafter) (s, dir); +} + +#endif diff --git a/libgfortran/generated/nearest_r16.c b/libgfortran/generated/nearest_r16.c new file mode 100644 index 000000000..1e8254f2c --- /dev/null +++ b/libgfortran/generated/nearest_r16.c @@ -0,0 +1,55 @@ +/* Implementation of the NEAREST intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#if defined(GFC_REAL_16_IS_FLOAT128) +#define MATHFUNC(funcname) funcname ## q +#else +#define MATHFUNC(funcname) funcname ## l +#endif + +#if defined (HAVE_GFC_REAL_16) && (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_COPYSIGNL)) && (defined(GFC_REAL_16_IS_FLOAT128) || 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 = MATHFUNC(copysign) (MATHFUNC(__builtin_inf) (), dir); + if (FLT_EVAL_METHOD != 0) + { + /* ??? Work around glibc bug on x86. */ + volatile GFC_REAL_16 r = MATHFUNC(nextafter) (s, dir); + return r; + } + else + return MATHFUNC(nextafter) (s, dir); +} + +#endif diff --git a/libgfortran/generated/nearest_r4.c b/libgfortran/generated/nearest_r4.c new file mode 100644 index 000000000..b26faea50 --- /dev/null +++ b/libgfortran/generated/nearest_r4.c @@ -0,0 +1,51 @@ +/* Implementation of the NEAREST intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## f + +#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); + +GFC_REAL_4 +nearest_r4 (GFC_REAL_4 s, GFC_REAL_4 dir) +{ + dir = MATHFUNC(copysign) (MATHFUNC(__builtin_inf) (), dir); + if (FLT_EVAL_METHOD != 0) + { + /* ??? Work around glibc bug on x86. */ + volatile GFC_REAL_4 r = MATHFUNC(nextafter) (s, dir); + return r; + } + else + return MATHFUNC(nextafter) (s, dir); +} + +#endif diff --git a/libgfortran/generated/nearest_r8.c b/libgfortran/generated/nearest_r8.c new file mode 100644 index 000000000..81505e934 --- /dev/null +++ b/libgfortran/generated/nearest_r8.c @@ -0,0 +1,51 @@ +/* Implementation of the NEAREST intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname + +#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); + +GFC_REAL_8 +nearest_r8 (GFC_REAL_8 s, GFC_REAL_8 dir) +{ + dir = MATHFUNC(copysign) (MATHFUNC(__builtin_inf) (), dir); + if (FLT_EVAL_METHOD != 0) + { + /* ??? Work around glibc bug on x86. */ + volatile GFC_REAL_8 r = MATHFUNC(nextafter) (s, dir); + return r; + } + else + return MATHFUNC(nextafter) (s, dir); +} + +#endif diff --git a/libgfortran/generated/norm2_r10.c b/libgfortran/generated/norm2_r10.c new file mode 100644 index 000000000..404cb1c16 --- /dev/null +++ b/libgfortran/generated/norm2_r10.c @@ -0,0 +1,212 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) && defined (HAVE_SQRTL) && defined (HAVE_FABSL) + +#define MATHFUNC(funcname) funcname ## l +#define BUILTINMATHFUNC(funcname) MATHFUNC(funcname) + + +extern void norm2_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(norm2_r10); + +void +norm2_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " NORM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "NORM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict src; + GFC_REAL_10 result; + src = base; + { + + GFC_REAL_10 scale; + result = 0; + scale = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src != 0) + { + GFC_REAL_10 absX, val; + absX = MATHFUNC(fabs) (*src); + if (scale < absX) + { + val = scale / absX; + result = 1 + result * val * val; + scale = absX; + } + else + { + val = absX / scale; + result += val * val; + } + } + } + result = scale * MATHFUNC(sqrt) (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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/norm2_r16.c b/libgfortran/generated/norm2_r16.c new file mode 100644 index 000000000..100f2e76d --- /dev/null +++ b/libgfortran/generated/norm2_r16.c @@ -0,0 +1,220 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) && (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_SQRTL)) && (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_FABSL)) + +#if defined(GFC_REAL_16_IS_FLOAT128) +#define MATHFUNC(funcname) funcname ## q +#else +#define MATHFUNC(funcname) funcname ## l +#endif +#if defined(GFC_REAL_16_IS_FLOAT128) +#define BUILTINMATHFUNC(funcname) funcname ## q +#else +#define BUILTINMATHFUNC(funcname) funcname ## l +#endif + + +extern void norm2_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(norm2_r16); + +void +norm2_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " NORM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "NORM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict src; + GFC_REAL_16 result; + src = base; + { + + GFC_REAL_16 scale; + result = 0; + scale = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src != 0) + { + GFC_REAL_16 absX, val; + absX = MATHFUNC(fabs) (*src); + if (scale < absX) + { + val = scale / absX; + result = 1 + result * val * val; + scale = absX; + } + else + { + val = absX / scale; + result += val * val; + } + } + } + result = scale * MATHFUNC(sqrt) (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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/norm2_r4.c b/libgfortran/generated/norm2_r4.c new file mode 100644 index 000000000..a86f76e0a --- /dev/null +++ b/libgfortran/generated/norm2_r4.c @@ -0,0 +1,212 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) && defined (HAVE_SQRTF) && defined (HAVE_FABSF) + +#define MATHFUNC(funcname) funcname ## f +#define BUILTINMATHFUNC(funcname) MATHFUNC(funcname) + + +extern void norm2_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(norm2_r4); + +void +norm2_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " NORM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "NORM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_REAL_4 result; + src = base; + { + + GFC_REAL_4 scale; + result = 0; + scale = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src != 0) + { + GFC_REAL_4 absX, val; + absX = MATHFUNC(fabs) (*src); + if (scale < absX) + { + val = scale / absX; + result = 1 + result * val * val; + scale = absX; + } + else + { + val = absX / scale; + result += val * val; + } + } + } + result = scale * MATHFUNC(sqrt) (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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/norm2_r8.c b/libgfortran/generated/norm2_r8.c new file mode 100644 index 000000000..14487e8b2 --- /dev/null +++ b/libgfortran/generated/norm2_r8.c @@ -0,0 +1,212 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) && defined (HAVE_SQRT) && defined (HAVE_FABS) + +#define MATHFUNC(funcname) funcname +#define BUILTINMATHFUNC(funcname) MATHFUNC(funcname) + + +extern void norm2_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(norm2_r8); + +void +norm2_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " NORM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "NORM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_REAL_8 result; + src = base; + { + + GFC_REAL_8 scale; + result = 0; + scale = 1; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + if (*src != 0) + { + GFC_REAL_8 absX, val; + absX = MATHFUNC(fabs) (*src); + if (scale < absX) + { + val = scale / absX; + result = 1 + result * val * val; + scale = absX; + } + else + { + val = absX / scale; + result += val * val; + } + } + } + result = scale * MATHFUNC(sqrt) (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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pack_c10.c b/libgfortran/generated/pack_c10.c new file mode 100644 index 000000000..cc66c538e --- /dev/null +++ b/libgfortran/generated/pack_c10.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, + const gfc_array_l1 *mask, const gfc_array_c10 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_COMPLEX_10 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_COMPLEX_10 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_10) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_c16.c b/libgfortran/generated/pack_c16.c new file mode 100644 index 000000000..9397262dd --- /dev/null +++ b/libgfortran/generated/pack_c16.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, + const gfc_array_l1 *mask, const gfc_array_c16 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_COMPLEX_16 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_COMPLEX_16 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_16) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_c4.c b/libgfortran/generated/pack_c4.c new file mode 100644 index 000000000..093bdcc9a --- /dev/null +++ b/libgfortran/generated/pack_c4.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, + const gfc_array_l1 *mask, const gfc_array_c4 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_COMPLEX_4 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_COMPLEX_4 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_4) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_c8.c b/libgfortran/generated/pack_c8.c new file mode 100644 index 000000000..7971e2ba1 --- /dev/null +++ b/libgfortran/generated/pack_c8.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, + const gfc_array_l1 *mask, const gfc_array_c8 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_COMPLEX_8 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_COMPLEX_8 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_8) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_i1.c b/libgfortran/generated/pack_i1.c new file mode 100644 index 000000000..3e4647dbd --- /dev/null +++ b/libgfortran/generated/pack_i1.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, + const gfc_array_l1 *mask, const gfc_array_i1 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_1 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_1 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_1) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_i16.c b/libgfortran/generated/pack_i16.c new file mode 100644 index 000000000..99d3491c3 --- /dev/null +++ b/libgfortran/generated/pack_i16.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, + const gfc_array_l1 *mask, const gfc_array_i16 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_16 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_16 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_i2.c b/libgfortran/generated/pack_i2.c new file mode 100644 index 000000000..e796d169f --- /dev/null +++ b/libgfortran/generated/pack_i2.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, + const gfc_array_l1 *mask, const gfc_array_i2 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_2 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_2 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_2) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_i4.c b/libgfortran/generated/pack_i4.c new file mode 100644 index 000000000..91ce99fe4 --- /dev/null +++ b/libgfortran/generated/pack_i4.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, + const gfc_array_l1 *mask, const gfc_array_i4 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_4 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_4 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_i8.c b/libgfortran/generated/pack_i8.c new file mode 100644 index 000000000..e49d8c29e --- /dev/null +++ b/libgfortran/generated/pack_i8.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, + const gfc_array_l1 *mask, const gfc_array_i8 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_INTEGER_8 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_INTEGER_8 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_r10.c b/libgfortran/generated/pack_r10.c new file mode 100644 index 000000000..f70c93264 --- /dev/null +++ b/libgfortran/generated/pack_r10.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, + const gfc_array_l1 *mask, const gfc_array_r10 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_REAL_10 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_REAL_10 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_REAL_10) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_r16.c b/libgfortran/generated/pack_r16.c new file mode 100644 index 000000000..ff2ad6e7e --- /dev/null +++ b/libgfortran/generated/pack_r16.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, + const gfc_array_l1 *mask, const gfc_array_r16 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_REAL_16 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_REAL_16 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_REAL_16) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_r4.c b/libgfortran/generated/pack_r4.c new file mode 100644 index 000000000..0c08b8c8c --- /dev/null +++ b/libgfortran/generated/pack_r4.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, + const gfc_array_l1 *mask, const gfc_array_r4 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_REAL_4 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_REAL_4 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_REAL_4) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/pack_r8.c b/libgfortran/generated/pack_r8.c new file mode 100644 index 000000000..2b307e29a --- /dev/null +++ b/libgfortran/generated/pack_r8.c @@ -0,0 +1,261 @@ +/* Specific implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +void +pack_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, + const gfc_array_l1 *mask, const gfc_array_r8 *vector) +{ + /* r.* indicates the return array. */ + index_type rstride0; + GFC_REAL_8 * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const GFC_REAL_8 *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (sstride[0] == 0) + sstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (zero_sized) + sptr = NULL; + else + sptr = array->data; + + if (ret->data == NULL || unlikely (compile_options.bounds_check)) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = GFC_DESCRIPTOR_EXTENT(vector,0); + if (total < 0) + { + total = 0; + vector = NULL; + } + } + else + { + /* We have to count the true elements in MASK. */ + total = count_0 (mask); + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1); + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (sizeof (GFC_REAL_8) * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0); + if (rstride0 == 0) + rstride0 = 1; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + *rptr = *sptr; + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = GFC_DESCRIPTOR_EXTENT(vector,0); + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (sstride0 == 0) + sstride0 = 1; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + *rptr = *sptr; + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/parity_l1.c b/libgfortran/generated/parity_l1.c new file mode 100644 index 000000000..4fef27744 --- /dev/null +++ b/libgfortran/generated/parity_l1.c @@ -0,0 +1,191 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_1) && defined (HAVE_GFC_LOGICAL_1) + + +extern void parity_l1 (gfc_array_l1 * const restrict, + gfc_array_l1 * const restrict, const index_type * const restrict); +export_proto(parity_l1); + +void +parity_l1 (gfc_array_l1 * const restrict retarray, + gfc_array_l1 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_1 * restrict base; + GFC_LOGICAL_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_1 * restrict src; + GFC_LOGICAL_1 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/parity_l16.c b/libgfortran/generated/parity_l16.c new file mode 100644 index 000000000..45f445716 --- /dev/null +++ b/libgfortran/generated/parity_l16.c @@ -0,0 +1,191 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_16) && defined (HAVE_GFC_LOGICAL_16) + + +extern void parity_l16 (gfc_array_l16 * const restrict, + gfc_array_l16 * const restrict, const index_type * const restrict); +export_proto(parity_l16); + +void +parity_l16 (gfc_array_l16 * const restrict retarray, + gfc_array_l16 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_16 * restrict base; + GFC_LOGICAL_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_16 * restrict src; + GFC_LOGICAL_16 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/parity_l2.c b/libgfortran/generated/parity_l2.c new file mode 100644 index 000000000..13e77bd52 --- /dev/null +++ b/libgfortran/generated/parity_l2.c @@ -0,0 +1,191 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_2) && defined (HAVE_GFC_LOGICAL_2) + + +extern void parity_l2 (gfc_array_l2 * const restrict, + gfc_array_l2 * const restrict, const index_type * const restrict); +export_proto(parity_l2); + +void +parity_l2 (gfc_array_l2 * const restrict retarray, + gfc_array_l2 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_2 * restrict base; + GFC_LOGICAL_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_2 * restrict src; + GFC_LOGICAL_2 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/parity_l4.c b/libgfortran/generated/parity_l4.c new file mode 100644 index 000000000..5d7fbbef6 --- /dev/null +++ b/libgfortran/generated/parity_l4.c @@ -0,0 +1,191 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_4) && defined (HAVE_GFC_LOGICAL_4) + + +extern void parity_l4 (gfc_array_l4 * const restrict, + gfc_array_l4 * const restrict, const index_type * const restrict); +export_proto(parity_l4); + +void +parity_l4 (gfc_array_l4 * const restrict retarray, + gfc_array_l4 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_4 * restrict base; + GFC_LOGICAL_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_4 * restrict src; + GFC_LOGICAL_4 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/parity_l8.c b/libgfortran/generated/parity_l8.c new file mode 100644 index 000000000..1d9ba82e0 --- /dev/null +++ b/libgfortran/generated/parity_l8.c @@ -0,0 +1,191 @@ +/* Implementation of the NORM2 intrinsic + Copyright 2010 Free Software Foundation, Inc. + Contributed by Tobias Burnus + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_LOGICAL_8) && defined (HAVE_GFC_LOGICAL_8) + + +extern void parity_l8 (gfc_array_l8 * const restrict, + gfc_array_l8 * const restrict, const index_type * const restrict); +export_proto(parity_l8); + +void +parity_l8 (gfc_array_l8 * const restrict retarray, + gfc_array_l8 * const restrict array, + const index_type * const restrict 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]; + const GFC_LOGICAL_8 * restrict base; + GFC_LOGICAL_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_LOGICAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PARITY intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PARITY"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + len = 0; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_LOGICAL_8 * restrict src; + GFC_LOGICAL_8 result; + src = base; + { + + result = 0; + if (len <= 0) + *dest = 0; + else + { + for (n = 0; n < len; n++, src += delta) + { + + 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/pow_c10_i16.c b/libgfortran/generated/pow_c10_i16.c new file mode 100644 index 000000000..48b2fd8fa --- /dev/null +++ b/libgfortran/generated/pow_c10_i16.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..2869f1d2d --- /dev/null +++ b/libgfortran/generated/pow_c10_i4.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_4 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..32ff9d454 --- /dev/null +++ b/libgfortran/generated/pow_c10_i8.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_8 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..668f85eda --- /dev/null +++ b/libgfortran/generated/pow_c16_i16.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..2d5be146c --- /dev/null +++ b/libgfortran/generated/pow_c16_i4.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_4 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..e599cf08b --- /dev/null +++ b/libgfortran/generated/pow_c16_i8.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_8 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..3f6ff8d87 --- /dev/null +++ b/libgfortran/generated/pow_c4_i16.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 new file mode 100644 index 000000000..b5cc430c6 --- /dev/null +++ b/libgfortran/generated/pow_c4_i4.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_4) + +GFC_COMPLEX_4 pow_c4_i4 (GFC_COMPLEX_4 a, GFC_INTEGER_4 b); +export_proto(pow_c4_i4); + +GFC_COMPLEX_4 +pow_c4_i4 (GFC_COMPLEX_4 a, GFC_INTEGER_4 b) +{ + GFC_COMPLEX_4 pow, x; + GFC_INTEGER_4 n; + GFC_UINTEGER_4 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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_i8.c b/libgfortran/generated/pow_c4_i8.c new file mode 100644 index 000000000..0bd0da7ce --- /dev/null +++ b/libgfortran/generated/pow_c4_i8.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_8) + +GFC_COMPLEX_4 pow_c4_i8 (GFC_COMPLEX_4 a, GFC_INTEGER_8 b); +export_proto(pow_c4_i8); + +GFC_COMPLEX_4 +pow_c4_i8 (GFC_COMPLEX_4 a, GFC_INTEGER_8 b) +{ + GFC_COMPLEX_4 pow, x; + GFC_INTEGER_8 n; + GFC_UINTEGER_8 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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_i16.c b/libgfortran/generated/pow_c8_i16.c new file mode 100644 index 000000000..8ac146548 --- /dev/null +++ b/libgfortran/generated/pow_c8_i16.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 new file mode 100644 index 000000000..d788c1bd6 --- /dev/null +++ b/libgfortran/generated/pow_c8_i4.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_4) + +GFC_COMPLEX_8 pow_c8_i4 (GFC_COMPLEX_8 a, GFC_INTEGER_4 b); +export_proto(pow_c8_i4); + +GFC_COMPLEX_8 +pow_c8_i4 (GFC_COMPLEX_8 a, GFC_INTEGER_4 b) +{ + GFC_COMPLEX_8 pow, x; + GFC_INTEGER_4 n; + GFC_UINTEGER_4 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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_i8.c b/libgfortran/generated/pow_c8_i8.c new file mode 100644 index 000000000..805146765 --- /dev/null +++ b/libgfortran/generated/pow_c8_i8.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_8) + +GFC_COMPLEX_8 pow_c8_i8 (GFC_COMPLEX_8 a, GFC_INTEGER_8 b); +export_proto(pow_c8_i8); + +GFC_COMPLEX_8 +pow_c8_i8 (GFC_COMPLEX_8 a, GFC_INTEGER_8 b) +{ + GFC_COMPLEX_8 pow, x; + GFC_INTEGER_8 n; + GFC_UINTEGER_8 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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_i16.c b/libgfortran/generated/pow_i16_i16.c new file mode 100644 index 000000000..62a88b11b --- /dev/null +++ b/libgfortran/generated/pow_i16_i16.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 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; + } + else + { + 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 000000000..2d4c87ca7 --- /dev/null +++ b/libgfortran/generated/pow_i16_i4.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_4 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; + } + else + { + 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 000000000..3c8401c6f --- /dev/null +++ b/libgfortran/generated/pow_i16_i8.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_8 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; + } + else + { + 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 000000000..c6a92f0a4 --- /dev/null +++ b/libgfortran/generated/pow_i4_i16.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 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; + } + else + { + 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 new file mode 100644 index 000000000..b8ffd7255 --- /dev/null +++ b/libgfortran/generated/pow_i4_i4.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_4) + +GFC_INTEGER_4 pow_i4_i4 (GFC_INTEGER_4 a, GFC_INTEGER_4 b); +export_proto(pow_i4_i4); + +GFC_INTEGER_4 +pow_i4_i4 (GFC_INTEGER_4 a, GFC_INTEGER_4 b) +{ + GFC_INTEGER_4 pow, x; + GFC_INTEGER_4 n; + GFC_UINTEGER_4 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; + } + else + { + 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_i8.c b/libgfortran/generated/pow_i4_i8.c new file mode 100644 index 000000000..76ac564ec --- /dev/null +++ b/libgfortran/generated/pow_i4_i8.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_8) + +GFC_INTEGER_4 pow_i4_i8 (GFC_INTEGER_4 a, GFC_INTEGER_8 b); +export_proto(pow_i4_i8); + +GFC_INTEGER_4 +pow_i4_i8 (GFC_INTEGER_4 a, GFC_INTEGER_8 b) +{ + GFC_INTEGER_4 pow, x; + GFC_INTEGER_8 n; + GFC_UINTEGER_8 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; + } + else + { + 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_i16.c b/libgfortran/generated/pow_i8_i16.c new file mode 100644 index 000000000..66a50b631 --- /dev/null +++ b/libgfortran/generated/pow_i8_i16.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 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; + } + else + { + 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 new file mode 100644 index 000000000..8b8594653 --- /dev/null +++ b/libgfortran/generated/pow_i8_i4.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_4) + +GFC_INTEGER_8 pow_i8_i4 (GFC_INTEGER_8 a, GFC_INTEGER_4 b); +export_proto(pow_i8_i4); + +GFC_INTEGER_8 +pow_i8_i4 (GFC_INTEGER_8 a, GFC_INTEGER_4 b) +{ + GFC_INTEGER_8 pow, x; + GFC_INTEGER_4 n; + GFC_UINTEGER_4 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; + } + else + { + 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_i8.c b/libgfortran/generated/pow_i8_i8.c new file mode 100644 index 000000000..bc5aa0dd8 --- /dev/null +++ b/libgfortran/generated/pow_i8_i8.c @@ -0,0 +1,77 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_8) + +GFC_INTEGER_8 pow_i8_i8 (GFC_INTEGER_8 a, GFC_INTEGER_8 b); +export_proto(pow_i8_i8); + +GFC_INTEGER_8 +pow_i8_i8 (GFC_INTEGER_8 a, GFC_INTEGER_8 b) +{ + GFC_INTEGER_8 pow, x; + GFC_INTEGER_8 n; + GFC_UINTEGER_8 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; + } + else + { + 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_i16.c b/libgfortran/generated/pow_r10_i16.c new file mode 100644 index 000000000..d587c4767 --- /dev/null +++ b/libgfortran/generated/pow_r10_i16.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..d2f66e019 --- /dev/null +++ b/libgfortran/generated/pow_r10_i8.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_8 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..0e80dd787 --- /dev/null +++ b/libgfortran/generated/pow_r16_i16.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..bba2a8445 --- /dev/null +++ b/libgfortran/generated/pow_r16_i4.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_4 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..16ea271e8 --- /dev/null +++ b/libgfortran/generated/pow_r16_i8.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_8 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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 000000000..3ba8d3e30 --- /dev/null +++ b/libgfortran/generated/pow_r4_i16.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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_i8.c b/libgfortran/generated/pow_r4_i8.c new file mode 100644 index 000000000..799adbaa8 --- /dev/null +++ b/libgfortran/generated/pow_r4_i8.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_8) + +GFC_REAL_4 pow_r4_i8 (GFC_REAL_4 a, GFC_INTEGER_8 b); +export_proto(pow_r4_i8); + +GFC_REAL_4 +pow_r4_i8 (GFC_REAL_4 a, GFC_INTEGER_8 b) +{ + GFC_REAL_4 pow, x; + GFC_INTEGER_8 n; + GFC_UINTEGER_8 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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_i16.c b/libgfortran/generated/pow_r8_i16.c new file mode 100644 index 000000000..4c7dcb7f0 --- /dev/null +++ b/libgfortran/generated/pow_r8_i16.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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; + GFC_UINTEGER_16 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + 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_i8.c b/libgfortran/generated/pow_r8_i8.c new file mode 100644 index 000000000..1a6a7460e --- /dev/null +++ b/libgfortran/generated/pow_r8_i8.c @@ -0,0 +1,75 @@ +/* Support routines for the intrinsic power (**) operator. + Copyright 2004, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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_8) + +GFC_REAL_8 pow_r8_i8 (GFC_REAL_8 a, GFC_INTEGER_8 b); +export_proto(pow_r8_i8); + +GFC_REAL_8 +pow_r8_i8 (GFC_REAL_8 a, GFC_INTEGER_8 b) +{ + GFC_REAL_8 pow, x; + GFC_INTEGER_8 n; + GFC_UINTEGER_8 u; + + n = b; + x = a; + pow = 1; + if (n != 0) + { + if (n < 0) + { + + u = -n; + x = pow / x; + } + else + { + u = n; + } + for (;;) + { + if (u & 1) + pow *= x; + u >>= 1; + if (u) + x *= x; + else + break; + } + } + return pow; +} + +#endif diff --git a/libgfortran/generated/product_c10.c b/libgfortran/generated/product_c10.c new file mode 100644 index 000000000..140aa305f --- /dev/null +++ b/libgfortran/generated/product_c10.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_COMPLEX_10) + + +extern void product_c10 (gfc_array_c10 * const restrict, + gfc_array_c10 * const restrict, const index_type * const restrict); +export_proto(product_c10); + +void +product_c10 (gfc_array_c10 * const restrict retarray, + gfc_array_c10 * const restrict array, + const index_type * const restrict 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]; + const GFC_COMPLEX_10 * restrict base; + GFC_COMPLEX_10 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_COMPLEX_10 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_c10 (gfc_array_c10 * const restrict, + gfc_array_c10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_c10); + +void +mproduct_c10 (gfc_array_c10 * const restrict retarray, + gfc_array_c10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_COMPLEX_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_COMPLEX_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_COMPLEX_10 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void sproduct_c10 (gfc_array_c10 * const restrict, + gfc_array_c10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_c10); + +void +sproduct_c10 (gfc_array_c10 * const restrict retarray, + gfc_array_c10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_10 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_c10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_c16.c b/libgfortran/generated/product_c16.c new file mode 100644 index 000000000..d59510248 --- /dev/null +++ b/libgfortran/generated/product_c16.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_COMPLEX_16) + + +extern void product_c16 (gfc_array_c16 * const restrict, + gfc_array_c16 * const restrict, const index_type * const restrict); +export_proto(product_c16); + +void +product_c16 (gfc_array_c16 * const restrict retarray, + gfc_array_c16 * const restrict array, + const index_type * const restrict 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]; + const GFC_COMPLEX_16 * restrict base; + GFC_COMPLEX_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_COMPLEX_16 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_c16 (gfc_array_c16 * const restrict, + gfc_array_c16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_c16); + +void +mproduct_c16 (gfc_array_c16 * const restrict retarray, + gfc_array_c16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_COMPLEX_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_COMPLEX_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_COMPLEX_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void sproduct_c16 (gfc_array_c16 * const restrict, + gfc_array_c16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_c16); + +void +sproduct_c16 (gfc_array_c16 * const restrict retarray, + gfc_array_c16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_c16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_c4.c b/libgfortran/generated/product_c4.c new file mode 100644 index 000000000..34c1bde26 --- /dev/null +++ b/libgfortran/generated/product_c4.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_COMPLEX_4) + + +extern void product_c4 (gfc_array_c4 * const restrict, + gfc_array_c4 * const restrict, const index_type * const restrict); +export_proto(product_c4); + +void +product_c4 (gfc_array_c4 * const restrict retarray, + gfc_array_c4 * const restrict array, + const index_type * const restrict 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]; + const GFC_COMPLEX_4 * restrict base; + GFC_COMPLEX_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_COMPLEX_4 * restrict src; + GFC_COMPLEX_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_c4 (gfc_array_c4 * const restrict, + gfc_array_c4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_c4); + +void +mproduct_c4 (gfc_array_c4 * const restrict retarray, + gfc_array_c4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_4 * restrict dest; + const GFC_COMPLEX_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_COMPLEX_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_COMPLEX_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_COMPLEX_4 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 probably 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]; + } + } + } +} + + +extern void sproduct_c4 (gfc_array_c4 * const restrict, + gfc_array_c4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_c4); + +void +sproduct_c4 (gfc_array_c4 * const restrict retarray, + gfc_array_c4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_c4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_c8.c b/libgfortran/generated/product_c8.c new file mode 100644 index 000000000..6e3487489 --- /dev/null +++ b/libgfortran/generated/product_c8.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_COMPLEX_8) + + +extern void product_c8 (gfc_array_c8 * const restrict, + gfc_array_c8 * const restrict, const index_type * const restrict); +export_proto(product_c8); + +void +product_c8 (gfc_array_c8 * const restrict retarray, + gfc_array_c8 * const restrict array, + const index_type * const restrict 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]; + const GFC_COMPLEX_8 * restrict base; + GFC_COMPLEX_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_COMPLEX_8 * restrict src; + GFC_COMPLEX_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_c8 (gfc_array_c8 * const restrict, + gfc_array_c8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_c8); + +void +mproduct_c8 (gfc_array_c8 * const restrict retarray, + gfc_array_c8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_8 * restrict dest; + const GFC_COMPLEX_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_COMPLEX_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_COMPLEX_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_COMPLEX_8 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 probably 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]; + } + } + } +} + + +extern void sproduct_c8 (gfc_array_c8 * const restrict, + gfc_array_c8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_c8); + +void +sproduct_c8 (gfc_array_c8 * const restrict retarray, + gfc_array_c8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_c8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_i1.c b/libgfortran/generated/product_i1.c new file mode 100644 index 000000000..2e0428718 --- /dev/null +++ b/libgfortran/generated/product_i1.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + + +extern void product_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(product_i1); + +void +product_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_1 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_i1); + +void +mproduct_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_1 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 probably 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]; + } + } + } +} + + +extern void sproduct_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_i1); + +void +sproduct_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_i16.c b/libgfortran/generated/product_i16.c new file mode 100644 index 000000000..e487ddfed --- /dev/null +++ b/libgfortran/generated/product_i16.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void product_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(product_i16); + +void +product_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_i16); + +void +mproduct_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void sproduct_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_i16); + +void +sproduct_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_i2.c b/libgfortran/generated/product_i2.c new file mode 100644 index 000000000..b4b0a4ce7 --- /dev/null +++ b/libgfortran/generated/product_i2.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) + + +extern void product_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(product_i2); + +void +product_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_2 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_i2); + +void +mproduct_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_2 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_2 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 probably 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]; + } + } + } +} + + +extern void sproduct_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_i2); + +void +sproduct_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_i4.c b/libgfortran/generated/product_i4.c new file mode 100644 index 000000000..a0164a161 --- /dev/null +++ b/libgfortran/generated/product_i4.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void product_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(product_i4); + +void +product_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_i4); + +void +mproduct_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 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 probably 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]; + } + } + } +} + + +extern void sproduct_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_i4); + +void +sproduct_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_i8.c b/libgfortran/generated/product_i8.c new file mode 100644 index 000000000..64c648774 --- /dev/null +++ b/libgfortran/generated/product_i8.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void product_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(product_i8); + +void +product_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_i8); + +void +mproduct_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 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 probably 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]; + } + } + } +} + + +extern void sproduct_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_i8); + +void +sproduct_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_r10.c b/libgfortran/generated/product_r10.c new file mode 100644 index 000000000..71a70da96 --- /dev/null +++ b/libgfortran/generated/product_r10.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) + + +extern void product_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(product_r10); + +void +product_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_r10); + +void +mproduct_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void sproduct_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_r10); + +void +sproduct_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_r16.c b/libgfortran/generated/product_r16.c new file mode 100644 index 000000000..0028ba1f8 --- /dev/null +++ b/libgfortran/generated/product_r16.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) + + +extern void product_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(product_r16); + +void +product_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_r16); + +void +mproduct_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void sproduct_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_r16); + +void +sproduct_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_r4.c b/libgfortran/generated/product_r4.c new file mode 100644 index 000000000..492980e67 --- /dev/null +++ b/libgfortran/generated/product_r4.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) + + +extern void product_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(product_r4); + +void +product_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_REAL_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_r4); + +void +mproduct_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_4 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_4 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 probably 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]; + } + } + } +} + + +extern void sproduct_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_r4); + +void +sproduct_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/product_r8.c b/libgfortran/generated/product_r8.c new file mode 100644 index 000000000..cf05af1fa --- /dev/null +++ b/libgfortran/generated/product_r8.c @@ -0,0 +1,508 @@ +/* Implementation of the PRODUCT intrinsic + Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) + + +extern void product_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(product_r8); + +void +product_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_REAL_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mproduct_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(mproduct_r8); + +void +mproduct_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_8 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in PRODUCT intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "PRODUCT"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "PRODUCT"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_8 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 probably 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]; + } + } + } +} + + +extern void sproduct_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(sproduct_r8); + +void +sproduct_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + product_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " PRODUCT intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " PRODUCT intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 1; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/reshape_c10.c b/libgfortran/generated/reshape_c10.c new file mode 100644 index 000000000..34eff9086 --- /dev/null +++ b/libgfortran/generated/reshape_c10.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_c10 (gfc_array_c10 * const restrict, + gfc_array_c10 * const restrict, + shape_type * const restrict, + gfc_array_c10 * const restrict, + shape_type * const restrict); +export_proto(reshape_c10); + +void +reshape_c10 (gfc_array_c10 * const restrict ret, + gfc_array_c10 * const restrict source, + shape_type * const restrict shape, + gfc_array_c10 * const restrict pad, + shape_type * const restrict 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; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, 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; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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 000000000..569b76ce4 --- /dev/null +++ b/libgfortran/generated/reshape_c16.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_c16 (gfc_array_c16 * const restrict, + gfc_array_c16 * const restrict, + shape_type * const restrict, + gfc_array_c16 * const restrict, + shape_type * const restrict); +export_proto(reshape_c16); + +void +reshape_c16 (gfc_array_c16 * const restrict ret, + gfc_array_c16 * const restrict source, + shape_type * const restrict shape, + gfc_array_c16 * const restrict pad, + shape_type * const restrict 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; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, 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; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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 new file mode 100644 index 000000000..c8b7355de --- /dev/null +++ b/libgfortran/generated/reshape_c4.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_c4 (gfc_array_c4 * const restrict, + gfc_array_c4 * const restrict, + shape_type * const restrict, + gfc_array_c4 * const restrict, + shape_type * const restrict); +export_proto(reshape_c4); + +void +reshape_c4 (gfc_array_c4 * const restrict ret, + gfc_array_c4 * const restrict source, + shape_type * const restrict shape, + gfc_array_c4 * const restrict pad, + shape_type * const restrict 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_4 *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_4 *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_4 *pptr; + + const GFC_COMPLEX_4 *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); + + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_COMPLEX_4)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_COMPLEX_4); + ssize *= sizeof (GFC_COMPLEX_4); + psize *= sizeof (GFC_COMPLEX_4); + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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_c8.c b/libgfortran/generated/reshape_c8.c new file mode 100644 index 000000000..1a390b450 --- /dev/null +++ b/libgfortran/generated/reshape_c8.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_c8 (gfc_array_c8 * const restrict, + gfc_array_c8 * const restrict, + shape_type * const restrict, + gfc_array_c8 * const restrict, + shape_type * const restrict); +export_proto(reshape_c8); + +void +reshape_c8 (gfc_array_c8 * const restrict ret, + gfc_array_c8 * const restrict source, + shape_type * const restrict shape, + gfc_array_c8 * const restrict pad, + shape_type * const restrict 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_8 *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_8 *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_8 *pptr; + + const GFC_COMPLEX_8 *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); + + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_COMPLEX_8)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_COMPLEX_8); + ssize *= sizeof (GFC_COMPLEX_8); + psize *= sizeof (GFC_COMPLEX_8); + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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_i16.c b/libgfortran/generated/reshape_i16.c new file mode 100644 index 000000000..4f69ce0d2 --- /dev/null +++ b/libgfortran/generated/reshape_i16.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, + shape_type * const restrict, + gfc_array_i16 * const restrict, + shape_type * const restrict); +export_proto(reshape_16); + +void +reshape_16 (gfc_array_i16 * const restrict ret, + gfc_array_i16 * const restrict source, + shape_type * const restrict shape, + gfc_array_i16 * const restrict pad, + shape_type * const restrict 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; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, 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; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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 new file mode 100644 index 000000000..53016bdf5 --- /dev/null +++ b/libgfortran/generated/reshape_i4.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, + shape_type * const restrict, + gfc_array_i4 * const restrict, + shape_type * const restrict); +export_proto(reshape_4); + +void +reshape_4 (gfc_array_i4 * const restrict ret, + gfc_array_i4 * const restrict source, + shape_type * const restrict shape, + gfc_array_i4 * const restrict pad, + shape_type * const restrict 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_4 *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_4 *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_4 *pptr; + + const GFC_INTEGER_4 *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); + + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_INTEGER_4)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_INTEGER_4); + ssize *= sizeof (GFC_INTEGER_4); + psize *= sizeof (GFC_INTEGER_4); + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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_i8.c b/libgfortran/generated/reshape_i8.c new file mode 100644 index 000000000..34620cf6d --- /dev/null +++ b/libgfortran/generated/reshape_i8.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, + shape_type * const restrict, + gfc_array_i8 * const restrict, + shape_type * const restrict); +export_proto(reshape_8); + +void +reshape_8 (gfc_array_i8 * const restrict ret, + gfc_array_i8 * const restrict source, + shape_type * const restrict shape, + gfc_array_i8 * const restrict pad, + shape_type * const restrict 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_8 *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_8 *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_8 *pptr; + + const GFC_INTEGER_8 *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); + + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_INTEGER_8)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_INTEGER_8); + ssize *= sizeof (GFC_INTEGER_8); + psize *= sizeof (GFC_INTEGER_8); + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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_r10.c b/libgfortran/generated/reshape_r10.c new file mode 100644 index 000000000..3bf319aa4 --- /dev/null +++ b/libgfortran/generated/reshape_r10.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, + shape_type * const restrict, + gfc_array_r10 * const restrict, + shape_type * const restrict); +export_proto(reshape_r10); + +void +reshape_r10 (gfc_array_r10 * const restrict ret, + gfc_array_r10 * const restrict source, + shape_type * const restrict shape, + gfc_array_r10 * const restrict pad, + shape_type * const restrict 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_REAL_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_REAL_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_REAL_10 *pptr; + + const GFC_REAL_10 *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); + + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_10)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_REAL_10); + ssize *= sizeof (GFC_REAL_10); + psize *= sizeof (GFC_REAL_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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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_r16.c b/libgfortran/generated/reshape_r16.c new file mode 100644 index 000000000..6794b5060 --- /dev/null +++ b/libgfortran/generated/reshape_r16.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, + shape_type * const restrict, + gfc_array_r16 * const restrict, + shape_type * const restrict); +export_proto(reshape_r16); + +void +reshape_r16 (gfc_array_r16 * const restrict ret, + gfc_array_r16 * const restrict source, + shape_type * const restrict shape, + gfc_array_r16 * const restrict pad, + shape_type * const restrict 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_REAL_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_REAL_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_REAL_16 *pptr; + + const GFC_REAL_16 *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); + + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_16)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_REAL_16); + ssize *= sizeof (GFC_REAL_16); + psize *= sizeof (GFC_REAL_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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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_r4.c b/libgfortran/generated/reshape_r4.c new file mode 100644 index 000000000..e7bfbfbf5 --- /dev/null +++ b/libgfortran/generated/reshape_r4.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, + shape_type * const restrict, + gfc_array_r4 * const restrict, + shape_type * const restrict); +export_proto(reshape_r4); + +void +reshape_r4 (gfc_array_r4 * const restrict ret, + gfc_array_r4 * const restrict source, + shape_type * const restrict shape, + gfc_array_r4 * const restrict pad, + shape_type * const restrict 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_REAL_4 *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_REAL_4 *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_REAL_4 *pptr; + + const GFC_REAL_4 *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); + + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_4)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_REAL_4); + ssize *= sizeof (GFC_REAL_4); + psize *= sizeof (GFC_REAL_4); + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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_r8.c b/libgfortran/generated/reshape_r8.c new file mode 100644 index 000000000..d0441c0fe --- /dev/null +++ b/libgfortran/generated/reshape_r8.c @@ -0,0 +1,352 @@ +/* Implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; + + +extern void reshape_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, + shape_type * const restrict, + gfc_array_r8 * const restrict, + shape_type * const restrict); +export_proto(reshape_r8); + +void +reshape_r8 (gfc_array_r8 * const restrict ret, + gfc_array_r8 * const restrict source, + shape_type * const restrict shape, + gfc_array_r8 * const restrict pad, + shape_type * const restrict 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_REAL_8 *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_REAL_8 *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_REAL_8 *pptr; + + const GFC_REAL_8 *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = GFC_DESCRIPTOR_EXTENT(shape,0); + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rs = 1; + for (n = 0; n < rdim; n++) + { + rex = shape_data[n]; + + GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs); + + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_8)); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n); + pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n); + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = GFC_DESCRIPTOR_EXTENT(source,n); + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim); + rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim); + if (rextent[n] < 0) + rextent[n] = 0; + + if (rextent[n] != shape_data[dim]) + 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; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n); + sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n); + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= sizeof (GFC_REAL_8); + ssize *= sizeof (GFC_REAL_8); + psize *= sizeof (GFC_REAL_8); + 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]; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[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 probably 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 probably 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/rrspacing_r10.c b/libgfortran/generated/rrspacing_r10.c new file mode 100644 index 000000000..78e17d104 --- /dev/null +++ b/libgfortran/generated/rrspacing_r10.c @@ -0,0 +1,54 @@ +/* Implementation of the RRSPACING intrinsic + Copyright 2006, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Steven G. Kargl + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## l + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_FABSL) && defined (HAVE_FREXPL) + +extern GFC_REAL_10 rrspacing_r10 (GFC_REAL_10 s, int p); +export_proto(rrspacing_r10); + +GFC_REAL_10 +rrspacing_r10 (GFC_REAL_10 s, int p) +{ + int e; + GFC_REAL_10 x; + x = MATHFUNC(fabs) (s); + if (x == 0.) + return 0.; + MATHFUNC(frexp) (s, &e); +#if defined (HAVE_LDEXPL) + return MATHFUNC(ldexp) (x, p - e); +#else + return MATHFUNC(scalbn) (x, p - e); +#endif + +} + +#endif diff --git a/libgfortran/generated/rrspacing_r16.c b/libgfortran/generated/rrspacing_r16.c new file mode 100644 index 000000000..470541e72 --- /dev/null +++ b/libgfortran/generated/rrspacing_r16.c @@ -0,0 +1,58 @@ +/* Implementation of the RRSPACING intrinsic + Copyright 2006, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Steven G. Kargl + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#if defined(GFC_REAL_16_IS_FLOAT128) +#define MATHFUNC(funcname) funcname ## q +#else +#define MATHFUNC(funcname) funcname ## l +#endif + +#if defined (HAVE_GFC_REAL_16) && (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_FABSL)) && (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_FREXPL)) + +extern GFC_REAL_16 rrspacing_r16 (GFC_REAL_16 s, int p); +export_proto(rrspacing_r16); + +GFC_REAL_16 +rrspacing_r16 (GFC_REAL_16 s, int p) +{ + int e; + GFC_REAL_16 x; + x = MATHFUNC(fabs) (s); + if (x == 0.) + return 0.; + MATHFUNC(frexp) (s, &e); +#if (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_LDEXPL)) + return MATHFUNC(ldexp) (x, p - e); +#else + return MATHFUNC(scalbn) (x, p - e); +#endif + +} + +#endif diff --git a/libgfortran/generated/rrspacing_r4.c b/libgfortran/generated/rrspacing_r4.c new file mode 100644 index 000000000..3c5243dbc --- /dev/null +++ b/libgfortran/generated/rrspacing_r4.c @@ -0,0 +1,54 @@ +/* Implementation of the RRSPACING intrinsic + Copyright 2006, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Steven G. Kargl + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## f + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_FABSF) && defined (HAVE_FREXPF) + +extern GFC_REAL_4 rrspacing_r4 (GFC_REAL_4 s, int p); +export_proto(rrspacing_r4); + +GFC_REAL_4 +rrspacing_r4 (GFC_REAL_4 s, int p) +{ + int e; + GFC_REAL_4 x; + x = MATHFUNC(fabs) (s); + if (x == 0.) + return 0.; + MATHFUNC(frexp) (s, &e); +#if defined (HAVE_LDEXPF) + return MATHFUNC(ldexp) (x, p - e); +#else + return MATHFUNC(scalbn) (x, p - e); +#endif + +} + +#endif diff --git a/libgfortran/generated/rrspacing_r8.c b/libgfortran/generated/rrspacing_r8.c new file mode 100644 index 000000000..1e4c99a52 --- /dev/null +++ b/libgfortran/generated/rrspacing_r8.c @@ -0,0 +1,54 @@ +/* Implementation of the RRSPACING intrinsic + Copyright 2006, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Steven G. Kargl + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_FABS) && defined (HAVE_FREXP) + +extern GFC_REAL_8 rrspacing_r8 (GFC_REAL_8 s, int p); +export_proto(rrspacing_r8); + +GFC_REAL_8 +rrspacing_r8 (GFC_REAL_8 s, int p) +{ + int e; + GFC_REAL_8 x; + x = MATHFUNC(fabs) (s); + if (x == 0.) + return 0.; + MATHFUNC(frexp) (s, &e); +#if defined (HAVE_LDEXP) + return MATHFUNC(ldexp) (x, p - e); +#else + return MATHFUNC(scalbn) (x, p - e); +#endif + +} + +#endif diff --git a/libgfortran/generated/set_exponent_r10.c b/libgfortran/generated/set_exponent_r10.c new file mode 100644 index 000000000..523b6028c --- /dev/null +++ b/libgfortran/generated/set_exponent_r10.c @@ -0,0 +1,44 @@ +/* Implementation of the SET_EXPONENT intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## l + +#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 MATHFUNC(scalbn) (MATHFUNC(frexp) (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 000000000..f9a7f3737 --- /dev/null +++ b/libgfortran/generated/set_exponent_r16.c @@ -0,0 +1,48 @@ +/* Implementation of the SET_EXPONENT intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#if defined(GFC_REAL_16_IS_FLOAT128) +#define MATHFUNC(funcname) funcname ## q +#else +#define MATHFUNC(funcname) funcname ## l +#endif + +#if defined (HAVE_GFC_REAL_16) && (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_SCALBNL)) && (defined(GFC_REAL_16_IS_FLOAT128) || 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 MATHFUNC(scalbn) (MATHFUNC(frexp) (s, &dummy_exp), i); +} + +#endif diff --git a/libgfortran/generated/set_exponent_r4.c b/libgfortran/generated/set_exponent_r4.c new file mode 100644 index 000000000..4554a408b --- /dev/null +++ b/libgfortran/generated/set_exponent_r4.c @@ -0,0 +1,44 @@ +/* Implementation of the SET_EXPONENT intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## f + +#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); + +GFC_REAL_4 +set_exponent_r4 (GFC_REAL_4 s, GFC_INTEGER_4 i) +{ + int dummy_exp; + return MATHFUNC(scalbn) (MATHFUNC(frexp) (s, &dummy_exp), i); +} + +#endif diff --git a/libgfortran/generated/set_exponent_r8.c b/libgfortran/generated/set_exponent_r8.c new file mode 100644 index 000000000..cb291d6d6 --- /dev/null +++ b/libgfortran/generated/set_exponent_r8.c @@ -0,0 +1,44 @@ +/* Implementation of the SET_EXPONENT intrinsic + Copyright 2003, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Richard Henderson . + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname + +#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); + +GFC_REAL_8 +set_exponent_r8 (GFC_REAL_8 s, GFC_INTEGER_4 i) +{ + int dummy_exp; + return MATHFUNC(scalbn) (MATHFUNC(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 000000000..802e00aef --- /dev/null +++ b/libgfortran/generated/shape_i16.c @@ -0,0 +1,67 @@ +/* Implementation of the SHAPE intrinsic + Copyright 2002, 2006, 2007, 2009, 2010 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +extern void shape_16 (gfc_array_i16 * const restrict ret, + const gfc_array_i16 * const restrict array); +export_proto(shape_16); + +void +shape_16 (gfc_array_i16 * const restrict ret, + const gfc_array_i16 * const restrict array) +{ + int n; + index_type stride; + index_type extent; + int rank; + + rank = GFC_DESCRIPTOR_RANK (array); + + if (ret->data == NULL) + { + GFC_DIMENSION_SET(ret->dim[0], 0, rank - 1, 1); + ret->offset = 0; + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); + } + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (GFC_DESCRIPTOR_EXTENT(ret,0) < 1) + return; + + for (n = 0; n < rank; n++) + { + extent = GFC_DESCRIPTOR_EXTENT(array,n); + ret->data[n * stride] = extent > 0 ? extent : 0 ; + } +} + +#endif diff --git a/libgfortran/generated/shape_i4.c b/libgfortran/generated/shape_i4.c new file mode 100644 index 000000000..fa2d4ebe2 --- /dev/null +++ b/libgfortran/generated/shape_i4.c @@ -0,0 +1,67 @@ +/* Implementation of the SHAPE intrinsic + Copyright 2002, 2006, 2007, 2009, 2010 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +extern void shape_4 (gfc_array_i4 * const restrict ret, + const gfc_array_i4 * const restrict array); +export_proto(shape_4); + +void +shape_4 (gfc_array_i4 * const restrict ret, + const gfc_array_i4 * const restrict array) +{ + int n; + index_type stride; + index_type extent; + int rank; + + rank = GFC_DESCRIPTOR_RANK (array); + + if (ret->data == NULL) + { + GFC_DIMENSION_SET(ret->dim[0], 0, rank - 1, 1); + ret->offset = 0; + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); + } + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (GFC_DESCRIPTOR_EXTENT(ret,0) < 1) + return; + + for (n = 0; n < rank; n++) + { + extent = GFC_DESCRIPTOR_EXTENT(array,n); + ret->data[n * stride] = extent > 0 ? extent : 0 ; + } +} + +#endif diff --git a/libgfortran/generated/shape_i8.c b/libgfortran/generated/shape_i8.c new file mode 100644 index 000000000..d6664de43 --- /dev/null +++ b/libgfortran/generated/shape_i8.c @@ -0,0 +1,67 @@ +/* Implementation of the SHAPE intrinsic + Copyright 2002, 2006, 2007, 2009, 2010 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +extern void shape_8 (gfc_array_i8 * const restrict ret, + const gfc_array_i8 * const restrict array); +export_proto(shape_8); + +void +shape_8 (gfc_array_i8 * const restrict ret, + const gfc_array_i8 * const restrict array) +{ + int n; + index_type stride; + index_type extent; + int rank; + + rank = GFC_DESCRIPTOR_RANK (array); + + if (ret->data == NULL) + { + GFC_DIMENSION_SET(ret->dim[0], 0, rank - 1, 1); + ret->offset = 0; + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); + } + + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + if (GFC_DESCRIPTOR_EXTENT(ret,0) < 1) + return; + + for (n = 0; n < rank; n++) + { + extent = GFC_DESCRIPTOR_EXTENT(array,n); + ret->data[n * stride] = extent > 0 ? extent : 0 ; + } +} + +#endif diff --git a/libgfortran/generated/spacing_r10.c b/libgfortran/generated/spacing_r10.c new file mode 100644 index 000000000..6905557ad --- /dev/null +++ b/libgfortran/generated/spacing_r10.c @@ -0,0 +1,53 @@ +/* Implementation of the SPACING intrinsic + Copyright 2006, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Steven G. Kargl + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## l + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_FREXPL) + +extern GFC_REAL_10 spacing_r10 (GFC_REAL_10 s, int p, int emin, GFC_REAL_10 tiny); +export_proto(spacing_r10); + +GFC_REAL_10 +spacing_r10 (GFC_REAL_10 s, int p, int emin, GFC_REAL_10 tiny) +{ + int e; + if (s == 0.) + return tiny; + MATHFUNC(frexp) (s, &e); + e = e - p; + e = e > emin ? e : emin; +#if defined (HAVE_LDEXPL) + return MATHFUNC(ldexp) (1., e); +#else + return MATHFUNC(scalbn) (1., e); +#endif +} + +#endif diff --git a/libgfortran/generated/spacing_r16.c b/libgfortran/generated/spacing_r16.c new file mode 100644 index 000000000..f58fa9640 --- /dev/null +++ b/libgfortran/generated/spacing_r16.c @@ -0,0 +1,57 @@ +/* Implementation of the SPACING intrinsic + Copyright 2006, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Steven G. Kargl + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#if defined(GFC_REAL_16_IS_FLOAT128) +#define MATHFUNC(funcname) funcname ## q +#else +#define MATHFUNC(funcname) funcname ## l +#endif + +#if defined (HAVE_GFC_REAL_16) && (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_FREXPL)) + +extern GFC_REAL_16 spacing_r16 (GFC_REAL_16 s, int p, int emin, GFC_REAL_16 tiny); +export_proto(spacing_r16); + +GFC_REAL_16 +spacing_r16 (GFC_REAL_16 s, int p, int emin, GFC_REAL_16 tiny) +{ + int e; + if (s == 0.) + return tiny; + MATHFUNC(frexp) (s, &e); + e = e - p; + e = e > emin ? e : emin; +#if (defined(GFC_REAL_16_IS_FLOAT128) || defined(HAVE_LDEXPL)) + return MATHFUNC(ldexp) (1., e); +#else + return MATHFUNC(scalbn) (1., e); +#endif +} + +#endif diff --git a/libgfortran/generated/spacing_r4.c b/libgfortran/generated/spacing_r4.c new file mode 100644 index 000000000..44cf577bd --- /dev/null +++ b/libgfortran/generated/spacing_r4.c @@ -0,0 +1,53 @@ +/* Implementation of the SPACING intrinsic + Copyright 2006, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Steven G. Kargl + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname ## f + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_FREXPF) + +extern GFC_REAL_4 spacing_r4 (GFC_REAL_4 s, int p, int emin, GFC_REAL_4 tiny); +export_proto(spacing_r4); + +GFC_REAL_4 +spacing_r4 (GFC_REAL_4 s, int p, int emin, GFC_REAL_4 tiny) +{ + int e; + if (s == 0.) + return tiny; + MATHFUNC(frexp) (s, &e); + e = e - p; + e = e > emin ? e : emin; +#if defined (HAVE_LDEXPF) + return MATHFUNC(ldexp) (1., e); +#else + return MATHFUNC(scalbn) (1., e); +#endif +} + +#endif diff --git a/libgfortran/generated/spacing_r8.c b/libgfortran/generated/spacing_r8.c new file mode 100644 index 000000000..4329adaa5 --- /dev/null +++ b/libgfortran/generated/spacing_r8.c @@ -0,0 +1,53 @@ +/* Implementation of the SPACING intrinsic + Copyright 2006, 2007, 2009, 2010 Free Software Foundation, Inc. + Contributed by Steven G. Kargl + +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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + + + +#define MATHFUNC(funcname) funcname + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_FREXP) + +extern GFC_REAL_8 spacing_r8 (GFC_REAL_8 s, int p, int emin, GFC_REAL_8 tiny); +export_proto(spacing_r8); + +GFC_REAL_8 +spacing_r8 (GFC_REAL_8 s, int p, int emin, GFC_REAL_8 tiny) +{ + int e; + if (s == 0.) + return tiny; + MATHFUNC(frexp) (s, &e); + e = e - p; + e = e > emin ? e : emin; +#if defined (HAVE_LDEXP) + return MATHFUNC(ldexp) (1., e); +#else + return MATHFUNC(scalbn) (1., e); +#endif +} + +#endif diff --git a/libgfortran/generated/spread_c10.c b/libgfortran/generated/spread_c10.c new file mode 100644 index 000000000..77a838f01 --- /dev/null +++ b/libgfortran/generated/spread_c10.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) + +void +spread_c10 (gfc_array_c10 *ret, const gfc_array_c10 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_COMPLEX_10 *rptr; + GFC_COMPLEX_10 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_COMPLEX_10 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_COMPLEX_10)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_c10 (gfc_array_c10 *ret, const GFC_COMPLEX_10 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_COMPLEX_10 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_COMPLEX_10)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_c16.c b/libgfortran/generated/spread_c16.c new file mode 100644 index 000000000..1276e4dfb --- /dev/null +++ b/libgfortran/generated/spread_c16.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) + +void +spread_c16 (gfc_array_c16 *ret, const gfc_array_c16 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_COMPLEX_16 *rptr; + GFC_COMPLEX_16 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_COMPLEX_16 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_COMPLEX_16)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_c16 (gfc_array_c16 *ret, const GFC_COMPLEX_16 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_COMPLEX_16 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_COMPLEX_16)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_c4.c b/libgfortran/generated/spread_c4.c new file mode 100644 index 000000000..5224e8477 --- /dev/null +++ b/libgfortran/generated/spread_c4.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +void +spread_c4 (gfc_array_c4 *ret, const gfc_array_c4 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_COMPLEX_4 *rptr; + GFC_COMPLEX_4 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_COMPLEX_4 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_COMPLEX_4)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_c4 (gfc_array_c4 *ret, const GFC_COMPLEX_4 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_COMPLEX_4 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_COMPLEX_4)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_c8.c b/libgfortran/generated/spread_c8.c new file mode 100644 index 000000000..96ecb3afb --- /dev/null +++ b/libgfortran/generated/spread_c8.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +void +spread_c8 (gfc_array_c8 *ret, const gfc_array_c8 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_COMPLEX_8 *rptr; + GFC_COMPLEX_8 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_COMPLEX_8 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_COMPLEX_8)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_c8 (gfc_array_c8 *ret, const GFC_COMPLEX_8 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_COMPLEX_8 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_COMPLEX_8)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_i1.c b/libgfortran/generated/spread_i1.c new file mode 100644 index 000000000..e002c1462 --- /dev/null +++ b/libgfortran/generated/spread_i1.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + +void +spread_i1 (gfc_array_i1 *ret, const gfc_array_i1 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_INTEGER_1 *rptr; + GFC_INTEGER_1 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_INTEGER_1 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_1)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_i1 (gfc_array_i1 *ret, const GFC_INTEGER_1 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_INTEGER_1 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_1)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_i16.c b/libgfortran/generated/spread_i16.c new file mode 100644 index 000000000..bdefdac32 --- /dev/null +++ b/libgfortran/generated/spread_i16.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +void +spread_i16 (gfc_array_i16 *ret, const gfc_array_i16 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_INTEGER_16 *rptr; + GFC_INTEGER_16 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_INTEGER_16 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_16)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_i16 (gfc_array_i16 *ret, const GFC_INTEGER_16 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_INTEGER_16 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_16)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_i2.c b/libgfortran/generated/spread_i2.c new file mode 100644 index 000000000..8482cfde8 --- /dev/null +++ b/libgfortran/generated/spread_i2.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + +void +spread_i2 (gfc_array_i2 *ret, const gfc_array_i2 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_INTEGER_2 *rptr; + GFC_INTEGER_2 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_INTEGER_2 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_2)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_i2 (gfc_array_i2 *ret, const GFC_INTEGER_2 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_INTEGER_2 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_2)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_i4.c b/libgfortran/generated/spread_i4.c new file mode 100644 index 000000000..6eff6326b --- /dev/null +++ b/libgfortran/generated/spread_i4.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +void +spread_i4 (gfc_array_i4 *ret, const gfc_array_i4 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_INTEGER_4 *rptr; + GFC_INTEGER_4 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_INTEGER_4 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_4)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_i4 (gfc_array_i4 *ret, const GFC_INTEGER_4 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_INTEGER_4 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_4)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_i8.c b/libgfortran/generated/spread_i8.c new file mode 100644 index 000000000..293126363 --- /dev/null +++ b/libgfortran/generated/spread_i8.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +void +spread_i8 (gfc_array_i8 *ret, const gfc_array_i8 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_INTEGER_8 *rptr; + GFC_INTEGER_8 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_INTEGER_8 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_8)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_i8 (gfc_array_i8 *ret, const GFC_INTEGER_8 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_INTEGER_8 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_INTEGER_8)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_r10.c b/libgfortran/generated/spread_r10.c new file mode 100644 index 000000000..3c3f197b4 --- /dev/null +++ b/libgfortran/generated/spread_r10.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +void +spread_r10 (gfc_array_r10 *ret, const gfc_array_r10 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_REAL_10 *rptr; + GFC_REAL_10 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_REAL_10 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_REAL_10)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_r10 (gfc_array_r10 *ret, const GFC_REAL_10 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_REAL_10 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_REAL_10)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_r16.c b/libgfortran/generated/spread_r16.c new file mode 100644 index 000000000..131626096 --- /dev/null +++ b/libgfortran/generated/spread_r16.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +void +spread_r16 (gfc_array_r16 *ret, const gfc_array_r16 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_REAL_16 *rptr; + GFC_REAL_16 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_REAL_16 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_REAL_16)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_r16 (gfc_array_r16 *ret, const GFC_REAL_16 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_REAL_16 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_REAL_16)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_r4.c b/libgfortran/generated/spread_r4.c new file mode 100644 index 000000000..cc0f1197b --- /dev/null +++ b/libgfortran/generated/spread_r4.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +void +spread_r4 (gfc_array_r4 *ret, const gfc_array_r4 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_REAL_4 *rptr; + GFC_REAL_4 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_REAL_4 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_REAL_4)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_r4 (gfc_array_r4 *ret, const GFC_REAL_4 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_REAL_4 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_REAL_4)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/spread_r8.c b/libgfortran/generated/spread_r8.c new file mode 100644 index 000000000..f38ef3885 --- /dev/null +++ b/libgfortran/generated/spread_r8.c @@ -0,0 +1,271 @@ +/* Special implementation of the SPREAD intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + spread_generic.c written 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +void +spread_r8 (gfc_array_r8 *ret, const gfc_array_r8 *source, + const index_type along, const index_type pncopies) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + GFC_REAL_8 *rptr; + GFC_REAL_8 * restrict dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const GFC_REAL_8 *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = pncopies; + + if (ret->data == NULL) + { + + size_t ub, stride; + + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + stride = rs; + if (n == along - 1) + { + ub = ncopies - 1; + rdelta = rs; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = rs; + + ub = extent[dim] - 1; + rs *= extent[dim]; + dim++; + } + GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride); + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * sizeof(GFC_REAL_8)); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (unlikely (compile_options.bounds_check)) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n); + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == along - 1) + { + rdelta = GFC_DESCRIPTOR_STRIDE(ret,n); + } + else + { + count[dim] = 0; + extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim); + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim); + rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n); + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = 1; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + *dest = *sptr; + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + 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 probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +void +spread_scalar_r8 (gfc_array_r8 *ret, const GFC_REAL_8 *source, + const index_type along, const index_type pncopies) +{ + int n; + int ncopies = pncopies; + GFC_REAL_8 * restrict dest; + index_type stride; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * sizeof (GFC_REAL_8)); + ret->offset = 0; + GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1); + } + else + { + if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1) + / GFC_DESCRIPTOR_STRIDE(ret,0)) + runtime_error ("dim too large in spread()"); + } + + dest = ret->data; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); + + for (n = 0; n < ncopies; n++) + { + *dest = *source; + dest += stride; + } +} + +#endif + diff --git a/libgfortran/generated/sum_c10.c b/libgfortran/generated/sum_c10.c new file mode 100644 index 000000000..b982bfea0 --- /dev/null +++ b/libgfortran/generated/sum_c10.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_COMPLEX_10) + + +extern void sum_c10 (gfc_array_c10 * const restrict, + gfc_array_c10 * const restrict, const index_type * const restrict); +export_proto(sum_c10); + +void +sum_c10 (gfc_array_c10 * const restrict retarray, + gfc_array_c10 * const restrict array, + const index_type * const restrict 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]; + const GFC_COMPLEX_10 * restrict base; + GFC_COMPLEX_10 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_COMPLEX_10 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_c10 (gfc_array_c10 * const restrict, + gfc_array_c10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_c10); + +void +msum_c10 (gfc_array_c10 * const restrict retarray, + gfc_array_c10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_COMPLEX_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_COMPLEX_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_COMPLEX_10 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void ssum_c10 (gfc_array_c10 * const restrict, + gfc_array_c10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_c10); + +void +ssum_c10 (gfc_array_c10 * const restrict retarray, + gfc_array_c10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_10 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_c10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_c16.c b/libgfortran/generated/sum_c16.c new file mode 100644 index 000000000..0bf2b69d7 --- /dev/null +++ b/libgfortran/generated/sum_c16.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_COMPLEX_16) + + +extern void sum_c16 (gfc_array_c16 * const restrict, + gfc_array_c16 * const restrict, const index_type * const restrict); +export_proto(sum_c16); + +void +sum_c16 (gfc_array_c16 * const restrict retarray, + gfc_array_c16 * const restrict array, + const index_type * const restrict 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]; + const GFC_COMPLEX_16 * restrict base; + GFC_COMPLEX_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_COMPLEX_16 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_c16 (gfc_array_c16 * const restrict, + gfc_array_c16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_c16); + +void +msum_c16 (gfc_array_c16 * const restrict retarray, + gfc_array_c16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_COMPLEX_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_COMPLEX_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_COMPLEX_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void ssum_c16 (gfc_array_c16 * const restrict, + gfc_array_c16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_c16); + +void +ssum_c16 (gfc_array_c16 * const restrict retarray, + gfc_array_c16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_c16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_c4.c b/libgfortran/generated/sum_c4.c new file mode 100644 index 000000000..a34e63cdd --- /dev/null +++ b/libgfortran/generated/sum_c4.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) && defined (HAVE_GFC_COMPLEX_4) + + +extern void sum_c4 (gfc_array_c4 * const restrict, + gfc_array_c4 * const restrict, const index_type * const restrict); +export_proto(sum_c4); + +void +sum_c4 (gfc_array_c4 * const restrict retarray, + gfc_array_c4 * const restrict array, + const index_type * const restrict 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]; + const GFC_COMPLEX_4 * restrict base; + GFC_COMPLEX_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_COMPLEX_4 * restrict src; + GFC_COMPLEX_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_c4 (gfc_array_c4 * const restrict, + gfc_array_c4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_c4); + +void +msum_c4 (gfc_array_c4 * const restrict retarray, + gfc_array_c4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_4 * restrict dest; + const GFC_COMPLEX_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_COMPLEX_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_COMPLEX_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_COMPLEX_4 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 probably 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]; + } + } + } +} + + +extern void ssum_c4 (gfc_array_c4 * const restrict, + gfc_array_c4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_c4); + +void +ssum_c4 (gfc_array_c4 * const restrict retarray, + gfc_array_c4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_c4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_c8.c b/libgfortran/generated/sum_c8.c new file mode 100644 index 000000000..42dea7b28 --- /dev/null +++ b/libgfortran/generated/sum_c8.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_COMPLEX_8) + + +extern void sum_c8 (gfc_array_c8 * const restrict, + gfc_array_c8 * const restrict, const index_type * const restrict); +export_proto(sum_c8); + +void +sum_c8 (gfc_array_c8 * const restrict retarray, + gfc_array_c8 * const restrict array, + const index_type * const restrict 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]; + const GFC_COMPLEX_8 * restrict base; + GFC_COMPLEX_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_COMPLEX_8 * restrict src; + GFC_COMPLEX_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_c8 (gfc_array_c8 * const restrict, + gfc_array_c8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_c8); + +void +msum_c8 (gfc_array_c8 * const restrict retarray, + gfc_array_c8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_8 * restrict dest; + const GFC_COMPLEX_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_COMPLEX_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_COMPLEX_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_COMPLEX_8 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 probably 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]; + } + } + } +} + + +extern void ssum_c8 (gfc_array_c8 * const restrict, + gfc_array_c8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_c8); + +void +ssum_c8 (gfc_array_c8 * const restrict retarray, + gfc_array_c8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_COMPLEX_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_c8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_COMPLEX_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_i1.c b/libgfortran/generated/sum_i1.c new file mode 100644 index 000000000..4eb6d6420 --- /dev/null +++ b/libgfortran/generated/sum_i1.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1) + + +extern void sum_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict); +export_proto(sum_i1); + +void +sum_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_1 * restrict base; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_1 * restrict src; + GFC_INTEGER_1 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_i1); + +void +msum_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_1 * restrict dest; + const GFC_INTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_1 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 probably 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]; + } + } + } +} + + +extern void ssum_i1 (gfc_array_i1 * const restrict, + gfc_array_i1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_i1); + +void +ssum_i1 (gfc_array_i1 * const restrict retarray, + gfc_array_i1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_1 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_i1 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_1) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_i16.c b/libgfortran/generated/sum_i16.c new file mode 100644 index 000000000..8e2c7b3ae --- /dev/null +++ b/libgfortran/generated/sum_i16.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void sum_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict); +export_proto(sum_i16); + +void +sum_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_16 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_i16); + +void +msum_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void ssum_i16 (gfc_array_i16 * const restrict, + gfc_array_i16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_i16); + +void +ssum_i16 (gfc_array_i16 * const restrict retarray, + gfc_array_i16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_i16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_i2.c b/libgfortran/generated/sum_i2.c new file mode 100644 index 000000000..12ef64d35 --- /dev/null +++ b/libgfortran/generated/sum_i2.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2) + + +extern void sum_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict); +export_proto(sum_i2); + +void +sum_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_2 * restrict base; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_2 * restrict src; + GFC_INTEGER_2 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_i2); + +void +msum_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_2 * restrict dest; + const GFC_INTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_2 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 probably 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]; + } + } + } +} + + +extern void ssum_i2 (gfc_array_i2 * const restrict, + gfc_array_i2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_i2); + +void +ssum_i2 (gfc_array_i2 * const restrict retarray, + gfc_array_i2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_2 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_i2 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_2) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_i4.c b/libgfortran/generated/sum_i4.c new file mode 100644 index 000000000..645ef436b --- /dev/null +++ b/libgfortran/generated/sum_i4.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void sum_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict); +export_proto(sum_i4); + +void +sum_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_4 * restrict src; + GFC_INTEGER_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_i4); + +void +msum_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 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 probably 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]; + } + } + } +} + + +extern void ssum_i4 (gfc_array_i4 * const restrict, + gfc_array_i4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_i4); + +void +ssum_i4 (gfc_array_i4 * const restrict retarray, + gfc_array_i4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_i4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_i8.c b/libgfortran/generated/sum_i8.c new file mode 100644 index 000000000..adb29b51c --- /dev/null +++ b/libgfortran/generated/sum_i8.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void sum_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict); +export_proto(sum_i8); + +void +sum_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict 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]; + const GFC_INTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_INTEGER_8 * restrict src; + GFC_INTEGER_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_i8); + +void +msum_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_INTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_INTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 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 probably 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]; + } + } + } +} + + +extern void ssum_i8 (gfc_array_i8 * const restrict, + gfc_array_i8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_i8); + +void +ssum_i8 (gfc_array_i8 * const restrict retarray, + gfc_array_i8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_i8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_r10.c b/libgfortran/generated/sum_r10.c new file mode 100644 index 000000000..9f588a5da --- /dev/null +++ b/libgfortran/generated/sum_r10.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10) + + +extern void sum_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict); +export_proto(sum_r10); + +void +sum_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_10 * restrict base; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_10 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_r10); + +void +msum_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_10 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_10 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void ssum_r10 (gfc_array_r10 * const restrict, + gfc_array_r10 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_r10); + +void +ssum_r10 (gfc_array_r10 * const restrict retarray, + gfc_array_r10 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_10 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_r10 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_10) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_r16.c b/libgfortran/generated/sum_r16.c new file mode 100644 index 000000000..292e66f71 --- /dev/null +++ b/libgfortran/generated/sum_r16.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16) + + +extern void sum_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict); +export_proto(sum_r16); + +void +sum_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_16 * restrict base; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_16 * restrict 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_r16); + +void +msum_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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 * restrict dest; + const GFC_REAL_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_16 * restrict src; + const GFC_LOGICAL_1 * restrict 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 probably 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]; + } + } + } +} + + +extern void ssum_r16 (gfc_array_r16 * const restrict, + gfc_array_r16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_r16); + +void +ssum_r16 (gfc_array_r16 * const restrict retarray, + gfc_array_r16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_r16 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_r4.c b/libgfortran/generated/sum_r4.c new file mode 100644 index 000000000..8fd563fc9 --- /dev/null +++ b/libgfortran/generated/sum_r4.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4) + + +extern void sum_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict); +export_proto(sum_r4); + +void +sum_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_4 * restrict base; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_4 * restrict src; + GFC_REAL_4 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_r4); + +void +msum_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_4 * restrict dest; + const GFC_REAL_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_4 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 probably 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]; + } + } + } +} + + +extern void ssum_r4 (gfc_array_r4 * const restrict, + gfc_array_r4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_r4); + +void +ssum_r4 (gfc_array_r4 * const restrict retarray, + gfc_array_r4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_r4 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/sum_r8.c b/libgfortran/generated/sum_r8.c new file mode 100644 index 000000000..e58398060 --- /dev/null +++ b/libgfortran/generated/sum_r8.c @@ -0,0 +1,508 @@ +/* Implementation of the SUM intrinsic + Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include + + +#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8) + + +extern void sum_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict); +export_proto(sum_r8); + +void +sum_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict 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]; + const GFC_REAL_8 * restrict base; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->data = internal_malloc_size (alloc_size); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->data; + dest = retarray->data; + + continue_loop = 1; + while (continue_loop) + { + const GFC_REAL_8 * restrict src; + GFC_REAL_8 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 probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + { + /* Break out of the look. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void msum_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict); +export_proto(msum_r8); + +void +msum_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict 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_8 * restrict dest; + const GFC_REAL_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + int rank; + int dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->data; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in SUM intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "SUM"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "SUM"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->data; + base = array->data; + + while (base) + { + const GFC_REAL_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_REAL_8 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 probably 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]; + } + } + } +} + + +extern void ssum_r8 (gfc_array_r8 * const restrict, + gfc_array_r8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *); +export_proto(ssum_r8); + +void +ssum_r8 (gfc_array_r8 * const restrict retarray, + gfc_array_r8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_REAL_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + sum_r8 (retarray, array, pdim); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->data == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1) + * extent[rank-1]; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->data = internal_malloc_size (alloc_size); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " SUM intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " SUM intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->data; + + while(1) + { + *dest = 0; + count[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 probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n == rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/transpose_c10.c b/libgfortran/generated/transpose_c10.c new file mode 100644 index 000000000..e740d12a7 --- /dev/null +++ b/libgfortran/generated/transpose_c10.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_COMPLEX_10) + +extern void transpose_c10 (gfc_array_c10 * const restrict ret, + gfc_array_c10 * const restrict source); +export_proto(transpose_c10); + +void +transpose_c10 (gfc_array_c10 * const restrict ret, + gfc_array_c10 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_COMPLEX_10 * restrict 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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_10) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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 000000000..31115bdfd --- /dev/null +++ b/libgfortran/generated/transpose_c16.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_COMPLEX_16) + +extern void transpose_c16 (gfc_array_c16 * const restrict ret, + gfc_array_c16 * const restrict source); +export_proto(transpose_c16); + +void +transpose_c16 (gfc_array_c16 * const restrict ret, + gfc_array_c16 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_COMPLEX_16 * restrict 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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_16) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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 new file mode 100644 index 000000000..a63f62c95 --- /dev/null +++ b/libgfortran/generated/transpose_c4.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +extern void transpose_c4 (gfc_array_c4 * const restrict ret, + gfc_array_c4 * const restrict source); +export_proto(transpose_c4); + +void +transpose_c4 (gfc_array_c4 * const restrict ret, + gfc_array_c4 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_COMPLEX_4 * restrict rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_COMPLEX_4 *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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_4) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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_c8.c b/libgfortran/generated/transpose_c8.c new file mode 100644 index 000000000..832239403 --- /dev/null +++ b/libgfortran/generated/transpose_c8.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +extern void transpose_c8 (gfc_array_c8 * const restrict ret, + gfc_array_c8 * const restrict source); +export_proto(transpose_c8); + +void +transpose_c8 (gfc_array_c8 * const restrict ret, + gfc_array_c8 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_COMPLEX_8 * restrict rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_COMPLEX_8 *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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_8) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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_i16.c b/libgfortran/generated/transpose_i16.c new file mode 100644 index 000000000..f8cfd823f --- /dev/null +++ b/libgfortran/generated/transpose_i16.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +extern void transpose_i16 (gfc_array_i16 * const restrict ret, + gfc_array_i16 * const restrict source); +export_proto(transpose_i16); + +void +transpose_i16 (gfc_array_i16 * const restrict ret, + gfc_array_i16 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_INTEGER_16 * restrict 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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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 new file mode 100644 index 000000000..9b15e4702 --- /dev/null +++ b/libgfortran/generated/transpose_i4.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +extern void transpose_i4 (gfc_array_i4 * const restrict ret, + gfc_array_i4 * const restrict source); +export_proto(transpose_i4); + +void +transpose_i4 (gfc_array_i4 * const restrict ret, + gfc_array_i4 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_INTEGER_4 * restrict rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_INTEGER_4 *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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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_i8.c b/libgfortran/generated/transpose_i8.c new file mode 100644 index 000000000..ddf772b0e --- /dev/null +++ b/libgfortran/generated/transpose_i8.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +extern void transpose_i8 (gfc_array_i8 * const restrict ret, + gfc_array_i8 * const restrict source); +export_proto(transpose_i8); + +void +transpose_i8 (gfc_array_i8 * const restrict ret, + gfc_array_i8 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_INTEGER_8 * restrict rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_INTEGER_8 *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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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_r10.c b/libgfortran/generated/transpose_r10.c new file mode 100644 index 000000000..2b2e02d1c --- /dev/null +++ b/libgfortran/generated/transpose_r10.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_REAL_10) + +extern void transpose_r10 (gfc_array_r10 * const restrict ret, + gfc_array_r10 * const restrict source); +export_proto(transpose_r10); + +void +transpose_r10 (gfc_array_r10 * const restrict ret, + gfc_array_r10 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_REAL_10 * restrict rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_REAL_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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_REAL_10) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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_r16.c b/libgfortran/generated/transpose_r16.c new file mode 100644 index 000000000..4d2e40660 --- /dev/null +++ b/libgfortran/generated/transpose_r16.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_REAL_16) + +extern void transpose_r16 (gfc_array_r16 * const restrict ret, + gfc_array_r16 * const restrict source); +export_proto(transpose_r16); + +void +transpose_r16 (gfc_array_r16 * const restrict ret, + gfc_array_r16 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_REAL_16 * restrict rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_REAL_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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_REAL_16) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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_r4.c b/libgfortran/generated/transpose_r4.c new file mode 100644 index 000000000..1748c1d05 --- /dev/null +++ b/libgfortran/generated/transpose_r4.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_REAL_4) + +extern void transpose_r4 (gfc_array_r4 * const restrict ret, + gfc_array_r4 * const restrict source); +export_proto(transpose_r4); + +void +transpose_r4 (gfc_array_r4 * const restrict ret, + gfc_array_r4 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_REAL_4 * restrict rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_REAL_4 *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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_REAL_4) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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_r8.c b/libgfortran/generated/transpose_r8.c new file mode 100644 index 000000000..09054b613 --- /dev/null +++ b/libgfortran/generated/transpose_r8.c @@ -0,0 +1,114 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_REAL_8) + +extern void transpose_r8 (gfc_array_r8 * const restrict ret, + gfc_array_r8 * const restrict source); +export_proto(transpose_r8); + +void +transpose_r8 (gfc_array_r8 * const restrict ret, + gfc_array_r8 * const restrict source) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + GFC_REAL_8 * restrict rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const GFC_REAL_8 *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); + + GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1, + 1); + + GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1, + GFC_DESCRIPTOR_EXTENT(source, 1)); + + ret->data = internal_malloc_size (sizeof (GFC_REAL_8) * size0 ((array_t *) ret)); + ret->offset = 0; + } else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0); + src_extent = GFC_DESCRIPTOR_EXTENT(source,1); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1); + src_extent = GFC_DESCRIPTOR_EXTENT(source,0); + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = GFC_DESCRIPTOR_STRIDE(source,0); + systride = GFC_DESCRIPTOR_STRIDE(source,1); + xcount = GFC_DESCRIPTOR_EXTENT(source,0); + ycount = GFC_DESCRIPTOR_EXTENT(source,1); + + rxstride = GFC_DESCRIPTOR_STRIDE(ret,0); + rystride = GFC_DESCRIPTOR_STRIDE(ret,1); + + 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/unpack_c10.c b/libgfortran/generated/unpack_c10.c new file mode 100644 index 000000000..9b89a5bea --- /dev/null +++ b/libgfortran/generated/unpack_c10.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_10) + +void +unpack0_c10 (gfc_array_c10 *ret, const gfc_array_c10 *vector, + const gfc_array_l1 *mask, const GFC_COMPLEX_10 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_COMPLEX_10 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_COMPLEX_10 *vptr; + /* Value for field, this is constant. */ + const GFC_COMPLEX_10 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_10)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_c10 (gfc_array_c10 *ret, const gfc_array_c10 *vector, + const gfc_array_l1 *mask, const gfc_array_c10 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_COMPLEX_10 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_COMPLEX_10 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_COMPLEX_10 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_10)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_c16.c b/libgfortran/generated/unpack_c16.c new file mode 100644 index 000000000..2d9931f02 --- /dev/null +++ b/libgfortran/generated/unpack_c16.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_16) + +void +unpack0_c16 (gfc_array_c16 *ret, const gfc_array_c16 *vector, + const gfc_array_l1 *mask, const GFC_COMPLEX_16 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_COMPLEX_16 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_COMPLEX_16 *vptr; + /* Value for field, this is constant. */ + const GFC_COMPLEX_16 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_16)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_c16 (gfc_array_c16 *ret, const gfc_array_c16 *vector, + const gfc_array_l1 *mask, const gfc_array_c16 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_COMPLEX_16 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_COMPLEX_16 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_COMPLEX_16 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_16)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_c4.c b/libgfortran/generated/unpack_c4.c new file mode 100644 index 000000000..116f213f9 --- /dev/null +++ b/libgfortran/generated/unpack_c4.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_4) + +void +unpack0_c4 (gfc_array_c4 *ret, const gfc_array_c4 *vector, + const gfc_array_l1 *mask, const GFC_COMPLEX_4 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_COMPLEX_4 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_COMPLEX_4 *vptr; + /* Value for field, this is constant. */ + const GFC_COMPLEX_4 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_4)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_c4 (gfc_array_c4 *ret, const gfc_array_c4 *vector, + const gfc_array_l1 *mask, const gfc_array_c4 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_COMPLEX_4 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_COMPLEX_4 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_COMPLEX_4 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_4)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_c8.c b/libgfortran/generated/unpack_c8.c new file mode 100644 index 000000000..7298eecee --- /dev/null +++ b/libgfortran/generated/unpack_c8.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_COMPLEX_8) + +void +unpack0_c8 (gfc_array_c8 *ret, const gfc_array_c8 *vector, + const gfc_array_l1 *mask, const GFC_COMPLEX_8 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_COMPLEX_8 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_COMPLEX_8 *vptr; + /* Value for field, this is constant. */ + const GFC_COMPLEX_8 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_8)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_c8 (gfc_array_c8 *ret, const gfc_array_c8 *vector, + const gfc_array_l1 *mask, const gfc_array_c8 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_COMPLEX_8 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_COMPLEX_8 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_COMPLEX_8 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_8)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_i1.c b/libgfortran/generated/unpack_i1.c new file mode 100644 index 000000000..f5dcb93df --- /dev/null +++ b/libgfortran/generated/unpack_i1.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_1) + +void +unpack0_i1 (gfc_array_i1 *ret, const gfc_array_i1 *vector, + const gfc_array_l1 *mask, const GFC_INTEGER_1 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_1 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_1 *vptr; + /* Value for field, this is constant. */ + const GFC_INTEGER_1 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_1)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_i1 (gfc_array_i1 *ret, const gfc_array_i1 *vector, + const gfc_array_l1 *mask, const gfc_array_i1 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_1 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_1 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_INTEGER_1 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_1)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_i16.c b/libgfortran/generated/unpack_i16.c new file mode 100644 index 000000000..77920ea60 --- /dev/null +++ b/libgfortran/generated/unpack_i16.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_16) + +void +unpack0_i16 (gfc_array_i16 *ret, const gfc_array_i16 *vector, + const gfc_array_l1 *mask, const GFC_INTEGER_16 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_16 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_16 *vptr; + /* Value for field, this is constant. */ + const GFC_INTEGER_16 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_16)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_i16 (gfc_array_i16 *ret, const gfc_array_i16 *vector, + const gfc_array_l1 *mask, const gfc_array_i16 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_16 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_16 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_INTEGER_16 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_16)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_i2.c b/libgfortran/generated/unpack_i2.c new file mode 100644 index 000000000..c7257bb2f --- /dev/null +++ b/libgfortran/generated/unpack_i2.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_2) + +void +unpack0_i2 (gfc_array_i2 *ret, const gfc_array_i2 *vector, + const gfc_array_l1 *mask, const GFC_INTEGER_2 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_2 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_2 *vptr; + /* Value for field, this is constant. */ + const GFC_INTEGER_2 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_2)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_i2 (gfc_array_i2 *ret, const gfc_array_i2 *vector, + const gfc_array_l1 *mask, const gfc_array_i2 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_2 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_2 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_INTEGER_2 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_2)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_i4.c b/libgfortran/generated/unpack_i4.c new file mode 100644 index 000000000..e3cdde677 --- /dev/null +++ b/libgfortran/generated/unpack_i4.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_4) + +void +unpack0_i4 (gfc_array_i4 *ret, const gfc_array_i4 *vector, + const gfc_array_l1 *mask, const GFC_INTEGER_4 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_4 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_4 *vptr; + /* Value for field, this is constant. */ + const GFC_INTEGER_4 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_4)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_i4 (gfc_array_i4 *ret, const gfc_array_i4 *vector, + const gfc_array_l1 *mask, const gfc_array_i4 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_4 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_4 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_INTEGER_4 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_4)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_i8.c b/libgfortran/generated/unpack_i8.c new file mode 100644 index 000000000..2f7206403 --- /dev/null +++ b/libgfortran/generated/unpack_i8.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_INTEGER_8) + +void +unpack0_i8 (gfc_array_i8 *ret, const gfc_array_i8 *vector, + const gfc_array_l1 *mask, const GFC_INTEGER_8 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_8 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_8 *vptr; + /* Value for field, this is constant. */ + const GFC_INTEGER_8 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_8)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_i8 (gfc_array_i8 *ret, const gfc_array_i8 *vector, + const gfc_array_l1 *mask, const gfc_array_i8 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_INTEGER_8 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_INTEGER_8 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_INTEGER_8 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_INTEGER_8)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_r10.c b/libgfortran/generated/unpack_r10.c new file mode 100644 index 000000000..796df2edd --- /dev/null +++ b/libgfortran/generated/unpack_r10.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_10) + +void +unpack0_r10 (gfc_array_r10 *ret, const gfc_array_r10 *vector, + const gfc_array_l1 *mask, const GFC_REAL_10 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_REAL_10 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_REAL_10 *vptr; + /* Value for field, this is constant. */ + const GFC_REAL_10 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_10)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_r10 (gfc_array_r10 *ret, const gfc_array_r10 *vector, + const gfc_array_l1 *mask, const gfc_array_r10 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_REAL_10 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_REAL_10 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_REAL_10 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_10)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_r16.c b/libgfortran/generated/unpack_r16.c new file mode 100644 index 000000000..b25d2869a --- /dev/null +++ b/libgfortran/generated/unpack_r16.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_16) + +void +unpack0_r16 (gfc_array_r16 *ret, const gfc_array_r16 *vector, + const gfc_array_l1 *mask, const GFC_REAL_16 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_REAL_16 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_REAL_16 *vptr; + /* Value for field, this is constant. */ + const GFC_REAL_16 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_16)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_r16 (gfc_array_r16 *ret, const gfc_array_r16 *vector, + const gfc_array_l1 *mask, const gfc_array_r16 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_REAL_16 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_REAL_16 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_REAL_16 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_16)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_r4.c b/libgfortran/generated/unpack_r4.c new file mode 100644 index 000000000..f4b763fc1 --- /dev/null +++ b/libgfortran/generated/unpack_r4.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_4) + +void +unpack0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector, + const gfc_array_l1 *mask, const GFC_REAL_4 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_REAL_4 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_REAL_4 *vptr; + /* Value for field, this is constant. */ + const GFC_REAL_4 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_4)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector, + const gfc_array_l1 *mask, const gfc_array_r4 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_REAL_4 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_REAL_4 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_REAL_4 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_4)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + diff --git a/libgfortran/generated/unpack_r8.c b/libgfortran/generated/unpack_r8.c new file mode 100644 index 000000000..dc9b4d398 --- /dev/null +++ b/libgfortran/generated/unpack_r8.c @@ -0,0 +1,331 @@ +/* Specific implementation of the UNPACK intrinsic + Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Thomas Koenig , based on + unpack_generic.c 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 3 of the License, or (at your option) any later version. + +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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include +#include +#include + + +#if defined (HAVE_GFC_REAL_8) + +void +unpack0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *vector, + const gfc_array_l1 *mask, const GFC_REAL_8 *fptr) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_REAL_8 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_REAL_8 *vptr; + /* Value for field, this is constant. */ + const GFC_REAL_8 fval = *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_8)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = fval; + } + /* Advance to the next element. */ + rptr += rstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + mptr += mstride[n]; + } + } + } +} + +void +unpack1_r8 (gfc_array_r8 *ret, const gfc_array_r8 *vector, + const gfc_array_l1 *mask, const gfc_array_r8 *field) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + GFC_REAL_8 * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + GFC_REAL_8 *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const GFC_REAL_8 *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Do not convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + GFC_DIMENSION_SET(ret->dim[n], 0, + GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs); + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * sizeof (GFC_REAL_8)); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n); + empty = empty || extent[n] <= 0; + rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n); + fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + } + if (rstride[0] == 0) + rstride[0] = 1; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = 1; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0); + if (vstride0 == 0) + vstride0 = 1; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + *rptr = *vptr; + vptr += vstride0; + } + else + { + /* From field. */ + *rptr = *fptr; + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + 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 probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +#endif + -- cgit v1.2.3