1 /* Implementation of the MINLOC intrinsic 2 Copyright (C) 2002-2020 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 4 5 This file is part of the GNU Fortran 95 runtime library (libgfortran). 6 7 Libgfortran is free software; you can redistribute it and/or 8 modify it under the terms of the GNU General Public 9 License as published by the Free Software Foundation; either 10 version 3 of the License, or (at your option) any later version. 11 12 Libgfortran is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 Under Section 7 of GPL version 3, you are granted additional 18 permissions described in the GCC Runtime Library Exception, version 19 3.1, as published by the Free Software Foundation. 20 21 You should have received a copy of the GNU General Public License and 22 a copy of the GCC Runtime Library Exception along with this program; 23 see 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_4) 31 32 33 extern void minloc0_4_r10 (gfc_array_i4 * const restrict retarray, 34 gfc_array_r10 * const restrict array, GFC_LOGICAL_4); 35 export_proto(minloc0_4_r10); 36 37 void 38 minloc0_4_r10 (gfc_array_i4 * const restrict retarray, cmap1_init1null39 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_4 * 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_4)); 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 179 extern void mminloc0_4_r10 (gfc_array_i4 * const restrict, 180 gfc_array_r10 * const restrict, gfc_array_l1 * const restrict, 181 GFC_LOGICAL_4); 182 export_proto(mminloc0_4_r10); 183 184 void 185 mminloc0_4_r10 (gfc_array_i4 * const restrict retarray, 186 gfc_array_r10 * const restrict array, 187 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) 188 { f2mnmxnull189 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_4 *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_4_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_4)); 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 364 extern void sminloc0_4_r10 (gfc_array_i4 * const restrict, 365 gfc_array_r10 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); 366 export_proto(sminloc0_4_r10); 367 368 void 369 sminloc0_4_r10 (gfc_array_i4 * 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_4 *dest; 377 378 if (mask == NULL || *mask) 379 { 380 minloc0_4_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_4)); 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