1 /* Implementation of the MAXLOC intrinsic 2 Copyright (C) 2017-2022 Free Software Foundation, Inc. 3 Contributed by Thomas Koenig 4 5 This file is part of the GNU Fortran 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 <stdlib.h> 28 #include <string.h> 29 #include <assert.h> 30 #include <limits.h> 31 32 33 #if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4) 34 35 static inline int 36 compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n) 37 { 38 if (sizeof (GFC_UINTEGER_4) == 1) 39 return memcmp (a, b, n); 40 else 41 return memcmp_char4 (a, b, n); 42 43 } 44 45 #define INITVAL 255 46 47 extern void minval0_s4 (GFC_UINTEGER_4 * restrict, 48 gfc_charlen_type, 49 gfc_array_s4 * const restrict array, gfc_charlen_type); 50 export_proto(minval0_s4); 51 52 void 53 minval0_s4 (GFC_UINTEGER_4 * restrict ret, 54 gfc_charlen_type xlen, 55 gfc_array_s4 * const restrict array, gfc_charlen_type len) 56 { 57 index_type count[GFC_MAX_DIMENSIONS]; 58 index_type extent[GFC_MAX_DIMENSIONS]; 59 index_type sstride[GFC_MAX_DIMENSIONS]; 60 const GFC_UINTEGER_4 *base; 61 index_type rank; 62 index_type n; 63 64 rank = GFC_DESCRIPTOR_RANK (array); 65 if (rank <= 0) 66 runtime_error ("Rank of array needs to be > 0"); 67 68 assert (xlen == len); 69 70 /* Initialize return value. */ 71 memset (ret, INITVAL, sizeof(*ret) * len); 72 73 for (n = 0; n < rank; n++) 74 { 75 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; 76 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 77 count[n] = 0; 78 if (extent[n] <= 0) 79 return; 80 } 81 82 base = array->base_addr; 83 84 { 85 86 const GFC_UINTEGER_4 *retval; 87 retval = ret; 88 89 while (base) 90 { 91 do 92 { 93 /* Implementation start. */ 94 95 if (compare_fcn (base, retval, len) < 0) 96 { 97 retval = base; 98 } 99 /* Implementation end. */ 100 /* Advance to the next element. */ 101 base += sstride[0]; 102 } 103 while (++count[0] != extent[0]); 104 n = 0; 105 do 106 { 107 /* When we get to the end of a dimension, reset it and increment 108 the next dimension. */ 109 count[n] = 0; 110 /* We could precalculate these products, but this is a less 111 frequently used path so probably not worth it. */ 112 base -= sstride[n] * extent[n]; 113 n++; 114 if (n >= rank) 115 { 116 /* Break out of the loop. */ 117 base = NULL; 118 break; 119 } 120 else 121 { 122 count[n]++; 123 base += sstride[n]; 124 } 125 } 126 while (count[n] == extent[n]); 127 } 128 memcpy (ret, retval, len * sizeof (*ret)); 129 } 130 } 131 132 133 extern void mminval0_s4 (GFC_UINTEGER_4 * restrict, 134 gfc_charlen_type, gfc_array_s4 * const restrict array, 135 gfc_array_l1 * const restrict mask, gfc_charlen_type len); 136 export_proto(mminval0_s4); 137 138 void 139 mminval0_s4 (GFC_UINTEGER_4 * const restrict ret, 140 gfc_charlen_type xlen, gfc_array_s4 * const restrict array, 141 gfc_array_l1 * const restrict mask, gfc_charlen_type len) 142 { 143 index_type count[GFC_MAX_DIMENSIONS]; 144 index_type extent[GFC_MAX_DIMENSIONS]; 145 index_type sstride[GFC_MAX_DIMENSIONS]; 146 index_type mstride[GFC_MAX_DIMENSIONS]; 147 const GFC_UINTEGER_4 *base; 148 GFC_LOGICAL_1 *mbase; 149 int rank; 150 index_type n; 151 int mask_kind; 152 153 if (mask == NULL) 154 { 155 minval0_s4 (ret, xlen, array, len); 156 return; 157 } 158 159 rank = GFC_DESCRIPTOR_RANK (array); 160 if (rank <= 0) 161 runtime_error ("Rank of array needs to be > 0"); 162 163 assert (xlen == len); 164 165 /* Initialize return value. */ 166 memset (ret, INITVAL, sizeof(*ret) * len); 167 168 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 169 170 mbase = mask->base_addr; 171 172 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 173 #ifdef HAVE_GFC_LOGICAL_16 174 || mask_kind == 16 175 #endif 176 ) 177 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 178 else 179 runtime_error ("Funny sized logical array"); 180 181 for (n = 0; n < rank; n++) 182 { 183 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; 184 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 185 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 186 count[n] = 0; 187 if (extent[n] <= 0) 188 return; 189 } 190 191 base = array->base_addr; 192 { 193 194 const GFC_UINTEGER_4 *retval; 195 196 retval = ret; 197 198 while (base) 199 { 200 do 201 { 202 /* Implementation start. */ 203 204 if (*mbase && compare_fcn (base, retval, len) < 0) 205 { 206 retval = base; 207 } 208 /* Implementation end. */ 209 /* Advance to the next element. */ 210 base += sstride[0]; 211 mbase += mstride[0]; 212 } 213 while (++count[0] != extent[0]); 214 n = 0; 215 do 216 { 217 /* When we get to the end of a dimension, reset it and increment 218 the next dimension. */ 219 count[n] = 0; 220 /* We could precalculate these products, but this is a less 221 frequently used path so probably not worth it. */ 222 base -= sstride[n] * extent[n]; 223 mbase -= mstride[n] * extent[n]; 224 n++; 225 if (n >= rank) 226 { 227 /* Break out of the loop. */ 228 base = NULL; 229 break; 230 } 231 else 232 { 233 count[n]++; 234 base += sstride[n]; 235 mbase += mstride[n]; 236 } 237 } 238 while (count[n] == extent[n]); 239 } 240 memcpy (ret, retval, len * sizeof (*ret)); 241 } 242 } 243 244 245 extern void sminval0_s4 (GFC_UINTEGER_4 * restrict, 246 gfc_charlen_type, 247 gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); 248 export_proto(sminval0_s4); 249 250 void 251 sminval0_s4 (GFC_UINTEGER_4 * restrict ret, 252 gfc_charlen_type xlen, gfc_array_s4 * const restrict array, 253 GFC_LOGICAL_4 *mask, gfc_charlen_type len) 254 255 { 256 if (mask == NULL || *mask) 257 { 258 minval0_s4 (ret, xlen, array, len); 259 return; 260 } 261 memset (ret, INITVAL, sizeof (*ret) * len); 262 } 263 264 #endif 265
Indexes created Mon Mar 30 00:23:01 UTC 2026