llvm-project

1
//===-- runtime/extrema.cpp -----------------------------------------------===//
2
//
3
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4
// See https://llvm.org/LICENSE.txt for license information.
5
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6
//
7
//===----------------------------------------------------------------------===//
8

9
// Implements MAXLOC, MINLOC, MAXVAL, & MINVAL for all required operand types
10
// and shapes and (for MAXLOC & MINLOC) result integer kinds.  Also implements
11
// NORM2 using common infrastructure.
12

13
#include "reduction-templates.h"
14
#include "flang/Common/float128.h"
15
#include "flang/Runtime/character.h"
16
#include "flang/Runtime/reduction.h"
17
#include <algorithm>
18
#include <cfloat>
19
#include <cinttypes>
20
#include <cmath>
21
#include <type_traits>
22

23
namespace Fortran::runtime {
24

25
// MAXLOC & MINLOC
26

27
template <typename T, bool IS_MAX, bool BACK> struct NumericCompare {
28
  using Type = T;
29
  explicit RT_API_ATTRS NumericCompare(std::size_t /*elemLen; ignored*/) {}
30
  RT_API_ATTRS bool operator()(const T &value, const T &previous) const {
31
    if (std::is_floating_point_v<T> && previous != previous) {
32
      return BACK || value == value; // replace NaN
33
    } else if (value == previous) {
34
      return BACK;
35
    } else if constexpr (IS_MAX) {
36
      return value > previous;
37
    } else {
38
      return value < previous;
39
    }
40
  }
41
};
42

43
template <typename T, bool IS_MAX, bool BACK> class CharacterCompare {
44
public:
45
  using Type = T;
46
  explicit RT_API_ATTRS CharacterCompare(std::size_t elemLen)
47
      : chars_{elemLen / sizeof(T)} {}
48
  RT_API_ATTRS bool operator()(const T &value, const T &previous) const {
49
    int cmp{CharacterScalarCompare<T>(&value, &previous, chars_, chars_)};
50
    if (cmp == 0) {
51
      return BACK;
52
    } else if constexpr (IS_MAX) {
53
      return cmp > 0;
54
    } else {
55
      return cmp < 0;
56
    }
57
  }
58

59
private:
60
  std::size_t chars_;
61
};
62

63
template <typename COMPARE> class ExtremumLocAccumulator {
64
public:
65
  using Type = typename COMPARE::Type;
66
  RT_API_ATTRS ExtremumLocAccumulator(const Descriptor &array)
67
      : array_{array}, argRank_{array.rank()}, compare_{array.ElementBytes()} {
68
    Reinitialize();
69
  }
70
  RT_API_ATTRS void Reinitialize() {
71
    // per standard: result indices are all zero if no data
72
    for (int j{0}; j < argRank_; ++j) {
73
      extremumLoc_[j] = 0;
74
    }
75
    previous_ = nullptr;
76
  }
77
  RT_API_ATTRS int argRank() const { return argRank_; }
78
  template <typename A>
79
  RT_API_ATTRS void GetResult(A *p, int zeroBasedDim = -1) {
80
    if (zeroBasedDim >= 0) {
81
      *p = extremumLoc_[zeroBasedDim];
82
    } else {
83
      for (int j{0}; j < argRank_; ++j) {
84
        p[j] = extremumLoc_[j];
85
      }
86
    }
87
  }
88
  template <typename IGNORED>
89
  RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {
90
    const auto &value{*array_.Element<Type>(at)};
91
    if (!previous_ || compare_(value, *previous_)) {
92
      previous_ = &value;
93
      for (int j{0}; j < argRank_; ++j) {
94
        extremumLoc_[j] = at[j] - array_.GetDimension(j).LowerBound() + 1;
95
      }
96
    }
97
    return true;
98
  }
99

100
private:
101
  const Descriptor &array_;
102
  int argRank_;
103
  SubscriptValue extremumLoc_[maxRank];
104
  const Type *previous_{nullptr};
105
  COMPARE compare_;
106
};
107

108
template <typename ACCUMULATOR, typename CPPTYPE>
109
static RT_API_ATTRS void LocationHelper(const char *intrinsic,
110
    Descriptor &result, const Descriptor &x, int kind, const Descriptor *mask,
111
    Terminator &terminator) {
112
  ACCUMULATOR accumulator{x};
113
  DoTotalReduction<CPPTYPE>(x, 0, mask, accumulator, intrinsic, terminator);
114
  ApplyIntegerKind<LocationResultHelper<ACCUMULATOR>::template Functor, void>(
115
      kind, terminator, accumulator, result);
116
}
117

118
template <TypeCategory CAT, int KIND, bool IS_MAX,
119
    template <typename, bool, bool> class COMPARE>
120
inline RT_API_ATTRS void DoMaxOrMinLoc(const char *intrinsic,
121
    Descriptor &result, const Descriptor &x, int kind, const char *source,
122
    int line, const Descriptor *mask, bool back) {
123
  using CppType = CppTypeFor<CAT, KIND>;
124
  Terminator terminator{source, line};
125
  if (back) {
126
    LocationHelper<ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, true>>,
127
        CppType>(intrinsic, result, x, kind, mask, terminator);
128
  } else {
129
    LocationHelper<ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, false>>,
130
        CppType>(intrinsic, result, x, kind, mask, terminator);
131
  }
132
}
133

134
template <bool IS_MAX> struct CharacterMaxOrMinLocHelper {
135
  template <int KIND> struct Functor {
136
    RT_API_ATTRS void operator()(const char *intrinsic, Descriptor &result,
137
        const Descriptor &x, int kind, const char *source, int line,
138
        const Descriptor *mask, bool back) const {
139
      DoMaxOrMinLoc<TypeCategory::Character, KIND, IS_MAX, CharacterCompare>(
140
          intrinsic, result, x, kind, source, line, mask, back);
141
    }
142
  };
143
};
144

145
template <bool IS_MAX>
146
inline RT_API_ATTRS void CharacterMaxOrMinLoc(const char *intrinsic,
147
    Descriptor &result, const Descriptor &x, int kind, const char *source,
148
    int line, const Descriptor *mask, bool back) {
149
  int rank{x.rank()};
150
  SubscriptValue extent[1]{rank};
151
  result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent,
152
      CFI_attribute_allocatable);
153
  result.GetDimension(0).SetBounds(1, extent[0]);
154
  Terminator terminator{source, line};
155
  if (int stat{result.Allocate()}) {
156
    terminator.Crash(
157
        "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);
158
  }
159
  CheckIntegerKind(terminator, kind, intrinsic);
160
  auto catKind{x.type().GetCategoryAndKind()};
161
  RUNTIME_CHECK(terminator, catKind.has_value());
162
  switch (catKind->first) {
163
  case TypeCategory::Character:
164
    ApplyCharacterKind<CharacterMaxOrMinLocHelper<IS_MAX>::template Functor,
165
        void>(catKind->second, terminator, intrinsic, result, x, kind, source,
166
        line, mask, back);
167
    break;
168
  default:
169
    terminator.Crash(
170
        "%s: bad data type code (%d) for array", intrinsic, x.type().raw());
171
  }
172
}
173

174
template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
175
inline RT_API_ATTRS void TotalNumericMaxOrMinLoc(const char *intrinsic,
176
    Descriptor &result, const Descriptor &x, int kind, const char *source,
177
    int line, const Descriptor *mask, bool back) {
178
  int rank{x.rank()};
179
  SubscriptValue extent[1]{rank};
180
  result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent,
181
      CFI_attribute_allocatable);
182
  result.GetDimension(0).SetBounds(1, extent[0]);
183
  Terminator terminator{source, line};
184
  if (int stat{result.Allocate()}) {
185
    terminator.Crash(
186
        "%s: could not allocate memory for result; STAT=%d", intrinsic, stat);
187
  }
188
  CheckIntegerKind(terminator, kind, intrinsic);
189
  RUNTIME_CHECK(terminator, TypeCode(CAT, KIND) == x.type());
190
  DoMaxOrMinLoc<CAT, KIND, IS_MAXVAL, NumericCompare>(
191
      intrinsic, result, x, kind, source, line, mask, back);
192
}
193

194
extern "C" {
195
RT_EXT_API_GROUP_BEGIN
196

197
void RTDEF(MaxlocCharacter)(Descriptor &result, const Descriptor &x, int kind,
198
    const char *source, int line, const Descriptor *mask, bool back) {
199
  CharacterMaxOrMinLoc<true>(
200
      "MAXLOC", result, x, kind, source, line, mask, back);
201
}
202
void RTDEF(MaxlocInteger1)(Descriptor &result, const Descriptor &x, int kind,
203
    const char *source, int line, const Descriptor *mask, bool back) {
204
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 1, true>(
205
      "MAXLOC", result, x, kind, source, line, mask, back);
206
}
207
void RTDEF(MaxlocInteger2)(Descriptor &result, const Descriptor &x, int kind,
208
    const char *source, int line, const Descriptor *mask, bool back) {
209
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 2, true>(
210
      "MAXLOC", result, x, kind, source, line, mask, back);
211
}
212
void RTDEF(MaxlocInteger4)(Descriptor &result, const Descriptor &x, int kind,
213
    const char *source, int line, const Descriptor *mask, bool back) {
214
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 4, true>(
215
      "MAXLOC", result, x, kind, source, line, mask, back);
216
}
217
void RTDEF(MaxlocInteger8)(Descriptor &result, const Descriptor &x, int kind,
218
    const char *source, int line, const Descriptor *mask, bool back) {
219
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 8, true>(
220
      "MAXLOC", result, x, kind, source, line, mask, back);
221
}
222
#ifdef __SIZEOF_INT128__
223
void RTDEF(MaxlocInteger16)(Descriptor &result, const Descriptor &x, int kind,
224
    const char *source, int line, const Descriptor *mask, bool back) {
225
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 16, true>(
226
      "MAXLOC", result, x, kind, source, line, mask, back);
227
}
228
#endif
229
void RTDEF(MaxlocReal4)(Descriptor &result, const Descriptor &x, int kind,
230
    const char *source, int line, const Descriptor *mask, bool back) {
231
  TotalNumericMaxOrMinLoc<TypeCategory::Real, 4, true>(
232
      "MAXLOC", result, x, kind, source, line, mask, back);
233
}
234
void RTDEF(MaxlocReal8)(Descriptor &result, const Descriptor &x, int kind,
235
    const char *source, int line, const Descriptor *mask, bool back) {
236
  TotalNumericMaxOrMinLoc<TypeCategory::Real, 8, true>(
237
      "MAXLOC", result, x, kind, source, line, mask, back);
238
}
239
#if LDBL_MANT_DIG == 64
240
void RTDEF(MaxlocReal10)(Descriptor &result, const Descriptor &x, int kind,
241
    const char *source, int line, const Descriptor *mask, bool back) {
242
  TotalNumericMaxOrMinLoc<TypeCategory::Real, 10, true>(
243
      "MAXLOC", result, x, kind, source, line, mask, back);
244
}
245
#endif
246
#if LDBL_MANT_DIG == 113 || HAS_FLOAT128
247
void RTDEF(MaxlocReal16)(Descriptor &result, const Descriptor &x, int kind,
248
    const char *source, int line, const Descriptor *mask, bool back) {
249
  TotalNumericMaxOrMinLoc<TypeCategory::Real, 16, true>(
250
      "MAXLOC", result, x, kind, source, line, mask, back);
251
}
252
#endif
253
void RTDEF(MinlocCharacter)(Descriptor &result, const Descriptor &x, int kind,
254
    const char *source, int line, const Descriptor *mask, bool back) {
255
  CharacterMaxOrMinLoc<false>(
256
      "MINLOC", result, x, kind, source, line, mask, back);
257
}
258
void RTDEF(MinlocInteger1)(Descriptor &result, const Descriptor &x, int kind,
259
    const char *source, int line, const Descriptor *mask, bool back) {
260
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 1, false>(
261
      "MINLOC", result, x, kind, source, line, mask, back);
262
}
263
void RTDEF(MinlocInteger2)(Descriptor &result, const Descriptor &x, int kind,
264
    const char *source, int line, const Descriptor *mask, bool back) {
265
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 2, false>(
266
      "MINLOC", result, x, kind, source, line, mask, back);
267
}
268
void RTDEF(MinlocInteger4)(Descriptor &result, const Descriptor &x, int kind,
269
    const char *source, int line, const Descriptor *mask, bool back) {
270
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 4, false>(
271
      "MINLOC", result, x, kind, source, line, mask, back);
272
}
273
void RTDEF(MinlocInteger8)(Descriptor &result, const Descriptor &x, int kind,
274
    const char *source, int line, const Descriptor *mask, bool back) {
275
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 8, false>(
276
      "MINLOC", result, x, kind, source, line, mask, back);
277
}
278
#ifdef __SIZEOF_INT128__
279
void RTDEF(MinlocInteger16)(Descriptor &result, const Descriptor &x, int kind,
280
    const char *source, int line, const Descriptor *mask, bool back) {
281
  TotalNumericMaxOrMinLoc<TypeCategory::Integer, 16, false>(
282
      "MINLOC", result, x, kind, source, line, mask, back);
283
}
284
#endif
285
void RTDEF(MinlocReal4)(Descriptor &result, const Descriptor &x, int kind,
286
    const char *source, int line, const Descriptor *mask, bool back) {
287
  TotalNumericMaxOrMinLoc<TypeCategory::Real, 4, false>(
288
      "MINLOC", result, x, kind, source, line, mask, back);
289
}
290
void RTDEF(MinlocReal8)(Descriptor &result, const Descriptor &x, int kind,
291
    const char *source, int line, const Descriptor *mask, bool back) {
292
  TotalNumericMaxOrMinLoc<TypeCategory::Real, 8, false>(
293
      "MINLOC", result, x, kind, source, line, mask, back);
294
}
295
#if LDBL_MANT_DIG == 64
296
void RTDEF(MinlocReal10)(Descriptor &result, const Descriptor &x, int kind,
297
    const char *source, int line, const Descriptor *mask, bool back) {
298
  TotalNumericMaxOrMinLoc<TypeCategory::Real, 10, false>(
299
      "MINLOC", result, x, kind, source, line, mask, back);
300
}
301
#endif
302
#if LDBL_MANT_DIG == 113 || HAS_FLOAT128
303
void RTDEF(MinlocReal16)(Descriptor &result, const Descriptor &x, int kind,
304
    const char *source, int line, const Descriptor *mask, bool back) {
305
  TotalNumericMaxOrMinLoc<TypeCategory::Real, 16, false>(
306
      "MINLOC", result, x, kind, source, line, mask, back);
307
}
308
#endif
309

310
RT_EXT_API_GROUP_END
311
} // extern "C"
312

313
// MAXLOC/MINLOC with DIM=
314

315
template <TypeCategory CAT, int KIND, bool IS_MAX,
316
    template <typename, bool, bool> class COMPARE, bool BACK>
317
static RT_API_ATTRS void DoPartialMaxOrMinLocDirection(const char *intrinsic,
318
    Descriptor &result, const Descriptor &x, int kind, int dim,
319
    const Descriptor *mask, Terminator &terminator) {
320
  using CppType = CppTypeFor<CAT, KIND>;
321
  using Accumulator = ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, BACK>>;
322
  Accumulator accumulator{x};
323
  ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, void>(
324
      kind, terminator, result, x, dim, mask, terminator, intrinsic,
325
      accumulator);
326
}
327

328
template <TypeCategory CAT, int KIND, bool IS_MAX,
329
    template <typename, bool, bool> class COMPARE>
330
inline RT_API_ATTRS void DoPartialMaxOrMinLoc(const char *intrinsic,
331
    Descriptor &result, const Descriptor &x, int kind, int dim,
332
    const Descriptor *mask, bool back, Terminator &terminator) {
333
  if (back) {
334
    DoPartialMaxOrMinLocDirection<CAT, KIND, IS_MAX, COMPARE, true>(
335
        intrinsic, result, x, kind, dim, mask, terminator);
336
  } else {
337
    DoPartialMaxOrMinLocDirection<CAT, KIND, IS_MAX, COMPARE, false>(
338
        intrinsic, result, x, kind, dim, mask, terminator);
339
  }
340
}
341

342
template <TypeCategory CAT, bool IS_MAX,
343
    template <typename, bool, bool> class COMPARE>
344
struct DoPartialMaxOrMinLocHelper {
345
  template <int KIND> struct Functor {
346
    RT_API_ATTRS void operator()(const char *intrinsic, Descriptor &result,
347
        const Descriptor &x, int kind, int dim, const Descriptor *mask,
348
        bool back, Terminator &terminator) const {
349
      DoPartialMaxOrMinLoc<CAT, KIND, IS_MAX, COMPARE>(
350
          intrinsic, result, x, kind, dim, mask, back, terminator);
351
    }
352
  };
353
};
354

355
template <bool IS_MAX>
356
inline RT_API_ATTRS void TypedPartialMaxOrMinLoc(const char *intrinsic,
357
    Descriptor &result, const Descriptor &x, int kind, int dim,
358
    const char *source, int line, const Descriptor *mask, bool back) {
359
  Terminator terminator{source, line};
360
  CheckIntegerKind(terminator, kind, intrinsic);
361
  auto catKind{x.type().GetCategoryAndKind()};
362
  RUNTIME_CHECK(terminator, catKind.has_value());
363
  const Descriptor *maskToUse{mask};
364
  SubscriptValue maskAt[maxRank]; // contents unused
365
  if (mask && mask->rank() == 0) {
366
    if (IsLogicalElementTrue(*mask, maskAt)) {
367
      // A scalar MASK that's .TRUE.  In this case, just get rid of the MASK.
368
      maskToUse = nullptr;
369
    } else {
370
      // For scalar MASK arguments that are .FALSE., return all zeroes
371

372
      // Element size of the destination descriptor is the size
373
      // of {TypeCategory::Integer, kind}.
374
      CreatePartialReductionResult(result, x,
375
          Descriptor::BytesFor(TypeCategory::Integer, kind), dim, terminator,
376
          intrinsic, TypeCode{TypeCategory::Integer, kind});
377
      std::memset(
378
          result.OffsetElement(), 0, result.Elements() * result.ElementBytes());
379
      return;
380
    }
381
  }
382
  switch (catKind->first) {
383
  case TypeCategory::Integer:
384
    ApplyIntegerKind<DoPartialMaxOrMinLocHelper<TypeCategory::Integer, IS_MAX,
385
                         NumericCompare>::template Functor,
386
        void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
387
        maskToUse, back, terminator);
388
    break;
389
  case TypeCategory::Real:
390
    ApplyFloatingPointKind<DoPartialMaxOrMinLocHelper<TypeCategory::Real,
391
                               IS_MAX, NumericCompare>::template Functor,
392
        void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
393
        maskToUse, back, terminator);
394
    break;
395
  case TypeCategory::Character:
396
    ApplyCharacterKind<DoPartialMaxOrMinLocHelper<TypeCategory::Character,
397
                           IS_MAX, CharacterCompare>::template Functor,
398
        void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
399
        maskToUse, back, terminator);
400
    break;
401
  default:
402
    terminator.Crash(
403
        "%s: bad data type code (%d) for array", intrinsic, x.type().raw());
404
  }
405
}
406

407
extern "C" {
408
RT_EXT_API_GROUP_BEGIN
409

410
void RTDEF(MaxlocDim)(Descriptor &result, const Descriptor &x, int kind,
411
    int dim, const char *source, int line, const Descriptor *mask, bool back) {
412
  TypedPartialMaxOrMinLoc<true>(
413
      "MAXLOC", result, x, kind, dim, source, line, mask, back);
414
}
415
void RTDEF(MinlocDim)(Descriptor &result, const Descriptor &x, int kind,
416
    int dim, const char *source, int line, const Descriptor *mask, bool back) {
417
  TypedPartialMaxOrMinLoc<false>(
418
      "MINLOC", result, x, kind, dim, source, line, mask, back);
419
}
420

421
RT_EXT_API_GROUP_END
422
} // extern "C"
423

424
// MAXVAL and MINVAL
425

426
template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
427
class NumericExtremumAccumulator {
428
public:
429
  using Type = CppTypeFor<CAT, KIND>;
430
  explicit RT_API_ATTRS NumericExtremumAccumulator(const Descriptor &array)
431
      : array_{array} {}
432
  RT_API_ATTRS void Reinitialize() {
433
    any_ = false;
434
    extremum_ = MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value();
435
  }
436
  template <typename A>
437
  RT_API_ATTRS void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {
438
    *p = extremum_;
439
  }
440
  RT_API_ATTRS bool Accumulate(Type x) {
441
    if (!any_) {
442
      extremum_ = x;
443
      any_ = true;
444
    } else if (CAT == TypeCategory::Real && extremum_ != extremum_) {
445
      extremum_ = x; // replace NaN
446
    } else if constexpr (IS_MAXVAL) {
447
      if (x > extremum_) {
448
        extremum_ = x;
449
      }
450
    } else if (x < extremum_) {
451
      extremum_ = x;
452
    }
453
    return true;
454
  }
455
  template <typename A>
456
  RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {
457
    return Accumulate(*array_.Element<A>(at));
458
  }
459

460
private:
461
  const Descriptor &array_;
462
  bool any_{false};
463
  Type extremum_{MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value()};
464
};
465

466
template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
467
inline RT_API_ATTRS CppTypeFor<CAT, KIND> TotalNumericMaxOrMin(
468
    const Descriptor &x, const char *source, int line, int dim,
469
    const Descriptor *mask, const char *intrinsic) {
470
  return GetTotalReduction<CAT, KIND>(x, source, line, dim, mask,
471
      NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>{x}, intrinsic);
472
}
473

474
template <TypeCategory CAT, bool IS_MAXVAL> struct MaxOrMinHelper {
475
  template <int KIND> struct Functor {
476
    RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,
477
        int dim, const Descriptor *mask, const char *intrinsic,
478
        Terminator &terminator) const {
479
      DoMaxMinNorm2<CAT, KIND,
480
          NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>>(
481
          result, x, dim, mask, intrinsic, terminator);
482
    }
483
  };
484
};
485

486
template <bool IS_MAXVAL>
487
inline RT_API_ATTRS void NumericMaxOrMin(Descriptor &result,
488
    const Descriptor &x, int dim, const char *source, int line,
489
    const Descriptor *mask, const char *intrinsic) {
490
  Terminator terminator{source, line};
491
  auto type{x.type().GetCategoryAndKind()};
492
  RUNTIME_CHECK(terminator, type);
493
  switch (type->first) {
494
  case TypeCategory::Integer:
495
    ApplyIntegerKind<
496
        MaxOrMinHelper<TypeCategory::Integer, IS_MAXVAL>::template Functor,
497
        void>(
498
        type->second, terminator, result, x, dim, mask, intrinsic, terminator);
499
    break;
500
  case TypeCategory::Real:
501
    ApplyFloatingPointKind<
502
        MaxOrMinHelper<TypeCategory::Real, IS_MAXVAL>::template Functor, void>(
503
        type->second, terminator, result, x, dim, mask, intrinsic, terminator);
504
    break;
505
  default:
506
    terminator.Crash("%s: bad type code %d", intrinsic, x.type().raw());
507
  }
508
}
509

510
template <int KIND, bool IS_MAXVAL> class CharacterExtremumAccumulator {
511
public:
512
  using Type = CppTypeFor<TypeCategory::Character, KIND>;
513
  explicit RT_API_ATTRS CharacterExtremumAccumulator(const Descriptor &array)
514
      : array_{array}, charLen_{array_.ElementBytes() / KIND} {}
515
  RT_API_ATTRS void Reinitialize() { extremum_ = nullptr; }
516
  template <typename A>
517
  RT_API_ATTRS void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {
518
    static_assert(std::is_same_v<A, Type>);
519
    std::size_t byteSize{array_.ElementBytes()};
520
    if (extremum_) {
521
      std::memcpy(p, extremum_, byteSize);
522
    } else {
523
      // Empty array; fill with character 0 for MAXVAL.
524
      // For MINVAL, set all of the bits.
525
      std::memset(p, IS_MAXVAL ? 0 : 255, byteSize);
526
    }
527
  }
528
  RT_API_ATTRS bool Accumulate(const Type *x) {
529
    if (!extremum_) {
530
      extremum_ = x;
531
    } else {
532
      int cmp{CharacterScalarCompare(x, extremum_, charLen_, charLen_)};
533
      if (IS_MAXVAL == (cmp > 0)) {
534
        extremum_ = x;
535
      }
536
    }
537
    return true;
538
  }
539
  template <typename A>
540
  RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {
541
    return Accumulate(array_.Element<A>(at));
542
  }
543

544
private:
545
  const Descriptor &array_;
546
  std::size_t charLen_;
547
  const Type *extremum_{nullptr};
548
};
549

550
template <bool IS_MAXVAL> struct CharacterMaxOrMinHelper {
551
  template <int KIND> struct Functor {
552
    RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,
553
        int dim, const Descriptor *mask, const char *intrinsic,
554
        Terminator &terminator) const {
555
      DoMaxMinNorm2<TypeCategory::Character, KIND,
556
          CharacterExtremumAccumulator<KIND, IS_MAXVAL>>(
557
          result, x, dim, mask, intrinsic, terminator);
558
    }
559
  };
560
};
561

562
template <bool IS_MAXVAL>
563
inline RT_API_ATTRS void CharacterMaxOrMin(Descriptor &result,
564
    const Descriptor &x, int dim, const char *source, int line,
565
    const Descriptor *mask, const char *intrinsic) {
566
  Terminator terminator{source, line};
567
  auto type{x.type().GetCategoryAndKind()};
568
  RUNTIME_CHECK(terminator, type && type->first == TypeCategory::Character);
569
  ApplyCharacterKind<CharacterMaxOrMinHelper<IS_MAXVAL>::template Functor,
570
      void>(
571
      type->second, terminator, result, x, dim, mask, intrinsic, terminator);
572
}
573

574
extern "C" {
575
RT_EXT_API_GROUP_BEGIN
576

577
CppTypeFor<TypeCategory::Integer, 1> RTDEF(MaxvalInteger1)(const Descriptor &x,
578
    const char *source, int line, int dim, const Descriptor *mask) {
579
  return TotalNumericMaxOrMin<TypeCategory::Integer, 1, true>(
580
      x, source, line, dim, mask, "MAXVAL");
581
}
582
CppTypeFor<TypeCategory::Integer, 2> RTDEF(MaxvalInteger2)(const Descriptor &x,
583
    const char *source, int line, int dim, const Descriptor *mask) {
584
  return TotalNumericMaxOrMin<TypeCategory::Integer, 2, true>(
585
      x, source, line, dim, mask, "MAXVAL");
586
}
587
CppTypeFor<TypeCategory::Integer, 4> RTDEF(MaxvalInteger4)(const Descriptor &x,
588
    const char *source, int line, int dim, const Descriptor *mask) {
589
  return TotalNumericMaxOrMin<TypeCategory::Integer, 4, true>(
590
      x, source, line, dim, mask, "MAXVAL");
591
}
592
CppTypeFor<TypeCategory::Integer, 8> RTDEF(MaxvalInteger8)(const Descriptor &x,
593
    const char *source, int line, int dim, const Descriptor *mask) {
594
  return TotalNumericMaxOrMin<TypeCategory::Integer, 8, true>(
595
      x, source, line, dim, mask, "MAXVAL");
596
}
597
#ifdef __SIZEOF_INT128__
598
CppTypeFor<TypeCategory::Integer, 16> RTDEF(MaxvalInteger16)(
599
    const Descriptor &x, const char *source, int line, int dim,
600
    const Descriptor *mask) {
601
  return TotalNumericMaxOrMin<TypeCategory::Integer, 16, true>(
602
      x, source, line, dim, mask, "MAXVAL");
603
}
604
#endif
605

606
// TODO: REAL(2 & 3)
607
CppTypeFor<TypeCategory::Real, 4> RTDEF(MaxvalReal4)(const Descriptor &x,
608
    const char *source, int line, int dim, const Descriptor *mask) {
609
  return TotalNumericMaxOrMin<TypeCategory::Real, 4, true>(
610
      x, source, line, dim, mask, "MAXVAL");
611
}
612
CppTypeFor<TypeCategory::Real, 8> RTDEF(MaxvalReal8)(const Descriptor &x,
613
    const char *source, int line, int dim, const Descriptor *mask) {
614
  return TotalNumericMaxOrMin<TypeCategory::Real, 8, true>(
615
      x, source, line, dim, mask, "MAXVAL");
616
}
617
#if LDBL_MANT_DIG == 64
618
CppTypeFor<TypeCategory::Real, 10> RTDEF(MaxvalReal10)(const Descriptor &x,
619
    const char *source, int line, int dim, const Descriptor *mask) {
620
  return TotalNumericMaxOrMin<TypeCategory::Real, 10, true>(
621
      x, source, line, dim, mask, "MAXVAL");
622
}
623
#endif
624
#if LDBL_MANT_DIG == 113 || HAS_FLOAT128
625
CppTypeFor<TypeCategory::Real, 16> RTDEF(MaxvalReal16)(const Descriptor &x,
626
    const char *source, int line, int dim, const Descriptor *mask) {
627
  return TotalNumericMaxOrMin<TypeCategory::Real, 16, true>(
628
      x, source, line, dim, mask, "MAXVAL");
629
}
630
#endif
631

632
void RTDEF(MaxvalCharacter)(Descriptor &result, const Descriptor &x,
633
    const char *source, int line, const Descriptor *mask) {
634
  CharacterMaxOrMin<true>(result, x, 0, source, line, mask, "MAXVAL");
635
}
636

637
CppTypeFor<TypeCategory::Integer, 1> RTDEF(MinvalInteger1)(const Descriptor &x,
638
    const char *source, int line, int dim, const Descriptor *mask) {
639
  return TotalNumericMaxOrMin<TypeCategory::Integer, 1, false>(
640
      x, source, line, dim, mask, "MINVAL");
641
}
642
CppTypeFor<TypeCategory::Integer, 2> RTDEF(MinvalInteger2)(const Descriptor &x,
643
    const char *source, int line, int dim, const Descriptor *mask) {
644
  return TotalNumericMaxOrMin<TypeCategory::Integer, 2, false>(
645
      x, source, line, dim, mask, "MINVAL");
646
}
647
CppTypeFor<TypeCategory::Integer, 4> RTDEF(MinvalInteger4)(const Descriptor &x,
648
    const char *source, int line, int dim, const Descriptor *mask) {
649
  return TotalNumericMaxOrMin<TypeCategory::Integer, 4, false>(
650
      x, source, line, dim, mask, "MINVAL");
651
}
652
CppTypeFor<TypeCategory::Integer, 8> RTDEF(MinvalInteger8)(const Descriptor &x,
653
    const char *source, int line, int dim, const Descriptor *mask) {
654
  return TotalNumericMaxOrMin<TypeCategory::Integer, 8, false>(
655
      x, source, line, dim, mask, "MINVAL");
656
}
657
#ifdef __SIZEOF_INT128__
658
CppTypeFor<TypeCategory::Integer, 16> RTDEF(MinvalInteger16)(
659
    const Descriptor &x, const char *source, int line, int dim,
660
    const Descriptor *mask) {
661
  return TotalNumericMaxOrMin<TypeCategory::Integer, 16, false>(
662
      x, source, line, dim, mask, "MINVAL");
663
}
664
#endif
665

666
// TODO: REAL(2 & 3)
667
CppTypeFor<TypeCategory::Real, 4> RTDEF(MinvalReal4)(const Descriptor &x,
668
    const char *source, int line, int dim, const Descriptor *mask) {
669
  return TotalNumericMaxOrMin<TypeCategory::Real, 4, false>(
670
      x, source, line, dim, mask, "MINVAL");
671
}
672
CppTypeFor<TypeCategory::Real, 8> RTDEF(MinvalReal8)(const Descriptor &x,
673
    const char *source, int line, int dim, const Descriptor *mask) {
674
  return TotalNumericMaxOrMin<TypeCategory::Real, 8, false>(
675
      x, source, line, dim, mask, "MINVAL");
676
}
677
#if LDBL_MANT_DIG == 64
678
CppTypeFor<TypeCategory::Real, 10> RTDEF(MinvalReal10)(const Descriptor &x,
679
    const char *source, int line, int dim, const Descriptor *mask) {
680
  return TotalNumericMaxOrMin<TypeCategory::Real, 10, false>(
681
      x, source, line, dim, mask, "MINVAL");
682
}
683
#endif
684
#if LDBL_MANT_DIG == 113 || HAS_FLOAT128
685
CppTypeFor<TypeCategory::Real, 16> RTDEF(MinvalReal16)(const Descriptor &x,
686
    const char *source, int line, int dim, const Descriptor *mask) {
687
  return TotalNumericMaxOrMin<TypeCategory::Real, 16, false>(
688
      x, source, line, dim, mask, "MINVAL");
689
}
690
#endif
691

692
void RTDEF(MinvalCharacter)(Descriptor &result, const Descriptor &x,
693
    const char *source, int line, const Descriptor *mask) {
694
  CharacterMaxOrMin<false>(result, x, 0, source, line, mask, "MINVAL");
695
}
696

697
void RTDEF(MaxvalDim)(Descriptor &result, const Descriptor &x, int dim,
698
    const char *source, int line, const Descriptor *mask) {
699
  if (x.type().IsCharacter()) {
700
    CharacterMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL");
701
  } else {
702
    NumericMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL");
703
  }
704
}
705
void RTDEF(MinvalDim)(Descriptor &result, const Descriptor &x, int dim,
706
    const char *source, int line, const Descriptor *mask) {
707
  if (x.type().IsCharacter()) {
708
    CharacterMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL");
709
  } else {
710
    NumericMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL");
711
  }
712
}
713

714
RT_EXT_API_GROUP_END
715
} // extern "C"
716

717
// NORM2
718

719
extern "C" {
720
RT_EXT_API_GROUP_BEGIN
721

722
// TODO: REAL(2 & 3)
723
CppTypeFor<TypeCategory::Real, 4> RTDEF(Norm2_4)(
724
    const Descriptor &x, const char *source, int line, int dim) {
725
  return GetTotalReduction<TypeCategory::Real, 4>(
726
      x, source, line, dim, nullptr, Norm2Accumulator<4>{x}, "NORM2");
727
}
728
CppTypeFor<TypeCategory::Real, 8> RTDEF(Norm2_8)(
729
    const Descriptor &x, const char *source, int line, int dim) {
730
  return GetTotalReduction<TypeCategory::Real, 8>(
731
      x, source, line, dim, nullptr, Norm2Accumulator<8>{x}, "NORM2");
732
}
733
#if LDBL_MANT_DIG == 64
734
CppTypeFor<TypeCategory::Real, 10> RTDEF(Norm2_10)(
735
    const Descriptor &x, const char *source, int line, int dim) {
736
  return GetTotalReduction<TypeCategory::Real, 10>(
737
      x, source, line, dim, nullptr, Norm2Accumulator<10>{x}, "NORM2");
738
}
739
#endif
740

741
void RTDEF(Norm2Dim)(Descriptor &result, const Descriptor &x, int dim,
742
    const char *source, int line) {
743
  Terminator terminator{source, line};
744
  auto type{x.type().GetCategoryAndKind()};
745
  RUNTIME_CHECK(terminator, type);
746
  if (type->first == TypeCategory::Real) {
747
    ApplyFloatingPointKind<Norm2Helper, void, true>(
748
        type->second, terminator, result, x, dim, nullptr, terminator);
749
  } else {
750
    terminator.Crash("NORM2: bad type code %d", x.type().raw());
751
  }
752
}
753

754
RT_EXT_API_GROUP_END
755
} // extern "C"
756
} // namespace Fortran::runtime
757