minloc0_16_r10.c revision 1.1.1.2
1/* Implementation of the MINLOC intrinsic 2 Copyright (C) 2002-2020 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 4 5This file is part of the GNU Fortran 95 runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24<http://www.gnu.org/licenses/>. */ 25 26#include "libgfortran.h" 27#include <assert.h> 28 29 30#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_16) 31 32 33extern void minloc0_16_r10 (gfc_array_i16 * const restrict retarray, 34 gfc_array_r10 * const restrict array, GFC_LOGICAL_4); 35export_proto(minloc0_16_r10); 36 37void 38minloc0_16_r10 (gfc_array_i16 * const restrict retarray, 39 gfc_array_r10 * const restrict array, GFC_LOGICAL_4 back) 40{ 41 index_type count[GFC_MAX_DIMENSIONS]; 42 index_type extent[GFC_MAX_DIMENSIONS]; 43 index_type sstride[GFC_MAX_DIMENSIONS]; 44 index_type dstride; 45 const GFC_REAL_10 *base; 46 GFC_INTEGER_16 * restrict dest; 47 index_type rank; 48 index_type n; 49 50 rank = GFC_DESCRIPTOR_RANK (array); 51 if (rank <= 0) 52 runtime_error ("Rank of array needs to be > 0"); 53 54 if (retarray->base_addr == NULL) 55 { 56 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 57 retarray->dtype.rank = 1; 58 retarray->offset = 0; 59 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); 60 } 61 else 62 { 63 if (unlikely (compile_options.bounds_check)) 64 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 65 "MINLOC"); 66 } 67 68 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 69 dest = retarray->base_addr; 70 for (n = 0; n < rank; n++) 71 { 72 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 73 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 74 count[n] = 0; 75 if (extent[n] <= 0) 76 { 77 /* Set the return value. */ 78 for (n = 0; n < rank; n++) 79 dest[n * dstride] = 0; 80 return; 81 } 82 } 83 84 base = array->base_addr; 85 86 /* Initialize the return value. */ 87 for (n = 0; n < rank; n++) 88 dest[n * dstride] = 1; 89 { 90 91 GFC_REAL_10 minval; 92#if defined(GFC_REAL_10_QUIET_NAN) 93 int fast = 0; 94#endif 95 96#if defined(GFC_REAL_10_INFINITY) 97 minval = GFC_REAL_10_INFINITY; 98#else 99 minval = GFC_REAL_10_HUGE; 100#endif 101 while (base) 102 { 103 /* Implementation start. */ 104 105#if defined(GFC_REAL_10_QUIET_NAN) 106 if (unlikely (!fast)) 107 { 108 do 109 { 110 if (*base <= minval) 111 { 112 fast = 1; 113 minval = *base; 114 for (n = 0; n < rank; n++) 115 dest[n * dstride] = count[n] + 1; 116 break; 117 } 118 base += sstride[0]; 119 } 120 while (++count[0] != extent[0]); 121 if (likely (fast)) 122 continue; 123 } 124 else 125#endif 126 if (back) 127 do 128 { 129 if (unlikely (*base <= minval)) 130 { 131 minval = *base; 132 for (n = 0; n < rank; n++) 133 dest[n * dstride] = count[n] + 1; 134 } 135 base += sstride[0]; 136 } 137 while (++count[0] != extent[0]); 138 else 139 do 140 { 141 if (unlikely (*base < minval)) 142 { 143 minval = *base; 144 for (n = 0; n < rank; n++) 145 dest[n * dstride] = count[n] + 1; 146 } 147 /* Implementation end. */ 148 /* Advance to the next element. */ 149 base += sstride[0]; 150 } 151 while (++count[0] != extent[0]); 152 n = 0; 153 do 154 { 155 /* When we get to the end of a dimension, reset it and increment 156 the next dimension. */ 157 count[n] = 0; 158 /* We could precalculate these products, but this is a less 159 frequently used path so probably not worth it. */ 160 base -= sstride[n] * extent[n]; 161 n++; 162 if (n >= rank) 163 { 164 /* Break out of the loop. */ 165 base = NULL; 166 break; 167 } 168 else 169 { 170 count[n]++; 171 base += sstride[n]; 172 } 173 } 174 while (count[n] == extent[n]); 175 } 176 } 177} 178 179extern void mminloc0_16_r10 (gfc_array_i16 * const restrict, 180 gfc_array_r10 * const restrict, gfc_array_l1 * const restrict, 181 GFC_LOGICAL_4); 182export_proto(mminloc0_16_r10); 183 184void 185mminloc0_16_r10 (gfc_array_i16 * const restrict retarray, 186 gfc_array_r10 * const restrict array, 187 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) 188{ 189 index_type count[GFC_MAX_DIMENSIONS]; 190 index_type extent[GFC_MAX_DIMENSIONS]; 191 index_type sstride[GFC_MAX_DIMENSIONS]; 192 index_type mstride[GFC_MAX_DIMENSIONS]; 193 index_type dstride; 194 GFC_INTEGER_16 *dest; 195 const GFC_REAL_10 *base; 196 GFC_LOGICAL_1 *mbase; 197 int rank; 198 index_type n; 199 int mask_kind; 200 201 202 if (mask == NULL) 203 { 204 minloc0_16_r10 (retarray, array, back); 205 return; 206 } 207 208 rank = GFC_DESCRIPTOR_RANK (array); 209 if (rank <= 0) 210 runtime_error ("Rank of array needs to be > 0"); 211 212 if (retarray->base_addr == NULL) 213 { 214 GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); 215 retarray->dtype.rank = 1; 216 retarray->offset = 0; 217 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); 218 } 219 else 220 { 221 if (unlikely (compile_options.bounds_check)) 222 { 223 224 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 225 "MINLOC"); 226 bounds_equal_extents ((array_t *) mask, (array_t *) array, 227 "MASK argument", "MINLOC"); 228 } 229 } 230 231 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 232 233 mbase = mask->base_addr; 234 235 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 236#ifdef HAVE_GFC_LOGICAL_16 237 || mask_kind == 16 238#endif 239 ) 240 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 241 else 242 runtime_error ("Funny sized logical array"); 243 244 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 245 dest = retarray->base_addr; 246 for (n = 0; n < rank; n++) 247 { 248 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 249 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 250 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 251 count[n] = 0; 252 if (extent[n] <= 0) 253 { 254 /* Set the return value. */ 255 for (n = 0; n < rank; n++) 256 dest[n * dstride] = 0; 257 return; 258 } 259 } 260 261 base = array->base_addr; 262 263 /* Initialize the return value. */ 264 for (n = 0; n < rank; n++) 265 dest[n * dstride] = 0; 266 { 267 268 GFC_REAL_10 minval; 269 int fast = 0; 270 271#if defined(GFC_REAL_10_INFINITY) 272 minval = GFC_REAL_10_INFINITY; 273#else 274 minval = GFC_REAL_10_HUGE; 275#endif 276 while (base) 277 { 278 /* Implementation start. */ 279 280 if (unlikely (!fast)) 281 { 282 do 283 { 284 if (*mbase) 285 { 286#if defined(GFC_REAL_10_QUIET_NAN) 287 if (unlikely (dest[0] == 0)) 288 for (n = 0; n < rank; n++) 289 dest[n * dstride] = count[n] + 1; 290 if (*base <= minval) 291#endif 292 { 293 fast = 1; 294 minval = *base; 295 for (n = 0; n < rank; n++) 296 dest[n * dstride] = count[n] + 1; 297 break; 298 } 299 } 300 base += sstride[0]; 301 mbase += mstride[0]; 302 } 303 while (++count[0] != extent[0]); 304 if (likely (fast)) 305 continue; 306 } 307 else 308 if (back) 309 do 310 { 311 if (unlikely (*mbase && (*base <= minval))) 312 { 313 minval = *base; 314 for (n = 0; n < rank; n++) 315 dest[n * dstride] = count[n] + 1; 316 } 317 base += sstride[0]; 318 } 319 while (++count[0] != extent[0]); 320 else 321 do 322 { 323 if (unlikely (*mbase && (*base < minval))) 324 { 325 minval = *base; 326 for (n = 0; n < rank; n++) 327 dest[n * dstride] = count[n] + 1; 328 } 329 /* Implementation end. */ 330 /* Advance to the next element. */ 331 base += sstride[0]; 332 mbase += mstride[0]; 333 } 334 while (++count[0] != extent[0]); 335 n = 0; 336 do 337 { 338 /* When we get to the end of a dimension, reset it and increment 339 the next dimension. */ 340 count[n] = 0; 341 /* We could precalculate these products, but this is a less 342 frequently used path so probably not worth it. */ 343 base -= sstride[n] * extent[n]; 344 mbase -= mstride[n] * extent[n]; 345 n++; 346 if (n >= rank) 347 { 348 /* Break out of the loop. */ 349 base = NULL; 350 break; 351 } 352 else 353 { 354 count[n]++; 355 base += sstride[n]; 356 mbase += mstride[n]; 357 } 358 } 359 while (count[n] == extent[n]); 360 } 361 } 362} 363 364extern void sminloc0_16_r10 (gfc_array_i16 * const restrict, 365 gfc_array_r10 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); 366export_proto(sminloc0_16_r10); 367 368void 369sminloc0_16_r10 (gfc_array_i16 * const restrict retarray, 370 gfc_array_r10 * const restrict array, 371 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) 372{ 373 index_type rank; 374 index_type dstride; 375 index_type n; 376 GFC_INTEGER_16 *dest; 377 378 if (mask == NULL || *mask) 379 { 380 minloc0_16_r10 (retarray, array, back); 381 return; 382 } 383 384 rank = GFC_DESCRIPTOR_RANK (array); 385 386 if (rank <= 0) 387 runtime_error ("Rank of array needs to be > 0"); 388 389 if (retarray->base_addr == NULL) 390 { 391 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); 392 retarray->dtype.rank = 1; 393 retarray->offset = 0; 394 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); 395 } 396 else if (unlikely (compile_options.bounds_check)) 397 { 398 bounds_iforeach_return ((array_t *) retarray, (array_t *) array, 399 "MINLOC"); 400 } 401 402 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); 403 dest = retarray->base_addr; 404 for (n = 0; n<rank; n++) 405 dest[n * dstride] = 0 ; 406} 407#endif 408