1//===-- lib/runtime/extrema.cpp ---------------------------------*- C++ -*-===//
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 "flang-rt/runtime/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
23namespace Fortran::runtime {
24
25// MAXLOC & MINLOC
26
27template <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
43template <typename T, bool IS_MAX, bool BACK> class CharacterCompare {
44public:
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
59private:
60 std::size_t chars_;
61};
62
63template <typename COMPARE> class ExtremumLocAccumulator {
64public:
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
100private:
101 const Descriptor &array_;
102 int argRank_;
103 SubscriptValue extremumLoc_[maxRank];
104 const Type *previous_{nullptr};
105 COMPARE compare_;
106};
107
108template <typename ACCUMULATOR, typename CPPTYPE>
109static 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
118template <TypeCategory CAT, int KIND, bool IS_MAX,
119 template <typename, bool, bool> class COMPARE>
120inline 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
134template <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
145template <bool IS_MAX>
146inline 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(kNoAsyncObject)}) {
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
174template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
175inline 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(kNoAsyncObject)}) {
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
194extern "C" {
195RT_EXT_API_GROUP_BEGIN
196
197void 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}
202void 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}
207void 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}
212void 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}
217void 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__
223void 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
229void RTDEF(MaxlocUnsigned1)(Descriptor &result, const Descriptor &x, int kind,
230 const char *source, int line, const Descriptor *mask, bool back) {
231 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 1, true>(
232 "MAXLOC", result, x, kind, source, line, mask, back);
233}
234void RTDEF(MaxlocUnsigned2)(Descriptor &result, const Descriptor &x, int kind,
235 const char *source, int line, const Descriptor *mask, bool back) {
236 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 2, true>(
237 "MAXLOC", result, x, kind, source, line, mask, back);
238}
239void RTDEF(MaxlocUnsigned4)(Descriptor &result, const Descriptor &x, int kind,
240 const char *source, int line, const Descriptor *mask, bool back) {
241 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 4, true>(
242 "MAXLOC", result, x, kind, source, line, mask, back);
243}
244void RTDEF(MaxlocUnsigned8)(Descriptor &result, const Descriptor &x, int kind,
245 const char *source, int line, const Descriptor *mask, bool back) {
246 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 8, true>(
247 "MAXLOC", result, x, kind, source, line, mask, back);
248}
249#ifdef __SIZEOF_INT128__
250void RTDEF(MaxlocUnsigned16)(Descriptor &result, const Descriptor &x, int kind,
251 const char *source, int line, const Descriptor *mask, bool back) {
252 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 16, true>(
253 "MAXLOC", result, x, kind, source, line, mask, back);
254}
255#endif
256void RTDEF(MaxlocReal4)(Descriptor &result, const Descriptor &x, int kind,
257 const char *source, int line, const Descriptor *mask, bool back) {
258 TotalNumericMaxOrMinLoc<TypeCategory::Real, 4, true>(
259 "MAXLOC", result, x, kind, source, line, mask, back);
260}
261void RTDEF(MaxlocReal8)(Descriptor &result, const Descriptor &x, int kind,
262 const char *source, int line, const Descriptor *mask, bool back) {
263 TotalNumericMaxOrMinLoc<TypeCategory::Real, 8, true>(
264 "MAXLOC", result, x, kind, source, line, mask, back);
265}
266#if HAS_FLOAT80
267void RTDEF(MaxlocReal10)(Descriptor &result, const Descriptor &x, int kind,
268 const char *source, int line, const Descriptor *mask, bool back) {
269 TotalNumericMaxOrMinLoc<TypeCategory::Real, 10, true>(
270 "MAXLOC", result, x, kind, source, line, mask, back);
271}
272#endif
273#if HAS_LDBL128 || HAS_FLOAT128
274void RTDEF(MaxlocReal16)(Descriptor &result, const Descriptor &x, int kind,
275 const char *source, int line, const Descriptor *mask, bool back) {
276 TotalNumericMaxOrMinLoc<TypeCategory::Real, 16, true>(
277 "MAXLOC", result, x, kind, source, line, mask, back);
278}
279#endif
280void RTDEF(MinlocCharacter)(Descriptor &result, const Descriptor &x, int kind,
281 const char *source, int line, const Descriptor *mask, bool back) {
282 CharacterMaxOrMinLoc<false>(
283 "MINLOC", result, x, kind, source, line, mask, back);
284}
285void RTDEF(MinlocInteger1)(Descriptor &result, const Descriptor &x, int kind,
286 const char *source, int line, const Descriptor *mask, bool back) {
287 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 1, false>(
288 "MINLOC", result, x, kind, source, line, mask, back);
289}
290void RTDEF(MinlocInteger2)(Descriptor &result, const Descriptor &x, int kind,
291 const char *source, int line, const Descriptor *mask, bool back) {
292 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 2, false>(
293 "MINLOC", result, x, kind, source, line, mask, back);
294}
295void RTDEF(MinlocInteger4)(Descriptor &result, const Descriptor &x, int kind,
296 const char *source, int line, const Descriptor *mask, bool back) {
297 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 4, false>(
298 "MINLOC", result, x, kind, source, line, mask, back);
299}
300void RTDEF(MinlocInteger8)(Descriptor &result, const Descriptor &x, int kind,
301 const char *source, int line, const Descriptor *mask, bool back) {
302 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 8, false>(
303 "MINLOC", result, x, kind, source, line, mask, back);
304}
305#ifdef __SIZEOF_INT128__
306void RTDEF(MinlocInteger16)(Descriptor &result, const Descriptor &x, int kind,
307 const char *source, int line, const Descriptor *mask, bool back) {
308 TotalNumericMaxOrMinLoc<TypeCategory::Integer, 16, false>(
309 "MINLOC", result, x, kind, source, line, mask, back);
310}
311#endif
312void RTDEF(MinlocUnsigned1)(Descriptor &result, const Descriptor &x, int kind,
313 const char *source, int line, const Descriptor *mask, bool back) {
314 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 1, false>(
315 "MINLOC", result, x, kind, source, line, mask, back);
316}
317void RTDEF(MinlocUnsigned2)(Descriptor &result, const Descriptor &x, int kind,
318 const char *source, int line, const Descriptor *mask, bool back) {
319 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 2, false>(
320 "MINLOC", result, x, kind, source, line, mask, back);
321}
322void RTDEF(MinlocUnsigned4)(Descriptor &result, const Descriptor &x, int kind,
323 const char *source, int line, const Descriptor *mask, bool back) {
324 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 4, false>(
325 "MINLOC", result, x, kind, source, line, mask, back);
326}
327void RTDEF(MinlocUnsigned8)(Descriptor &result, const Descriptor &x, int kind,
328 const char *source, int line, const Descriptor *mask, bool back) {
329 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 8, false>(
330 "MINLOC", result, x, kind, source, line, mask, back);
331}
332#ifdef __SIZEOF_INT128__
333void RTDEF(MinlocUnsigned16)(Descriptor &result, const Descriptor &x, int kind,
334 const char *source, int line, const Descriptor *mask, bool back) {
335 TotalNumericMaxOrMinLoc<TypeCategory::Unsigned, 16, false>(
336 "MINLOC", result, x, kind, source, line, mask, back);
337}
338#endif
339void RTDEF(MinlocReal4)(Descriptor &result, const Descriptor &x, int kind,
340 const char *source, int line, const Descriptor *mask, bool back) {
341 TotalNumericMaxOrMinLoc<TypeCategory::Real, 4, false>(
342 "MINLOC", result, x, kind, source, line, mask, back);
343}
344void RTDEF(MinlocReal8)(Descriptor &result, const Descriptor &x, int kind,
345 const char *source, int line, const Descriptor *mask, bool back) {
346 TotalNumericMaxOrMinLoc<TypeCategory::Real, 8, false>(
347 "MINLOC", result, x, kind, source, line, mask, back);
348}
349#if HAS_FLOAT80
350void RTDEF(MinlocReal10)(Descriptor &result, const Descriptor &x, int kind,
351 const char *source, int line, const Descriptor *mask, bool back) {
352 TotalNumericMaxOrMinLoc<TypeCategory::Real, 10, false>(
353 "MINLOC", result, x, kind, source, line, mask, back);
354}
355#endif
356#if HAS_LDBL128 || HAS_FLOAT128
357void RTDEF(MinlocReal16)(Descriptor &result, const Descriptor &x, int kind,
358 const char *source, int line, const Descriptor *mask, bool back) {
359 TotalNumericMaxOrMinLoc<TypeCategory::Real, 16, false>(
360 "MINLOC", result, x, kind, source, line, mask, back);
361}
362#endif
363
364RT_EXT_API_GROUP_END
365} // extern "C"
366
367// MAXLOC/MINLOC with DIM=
368
369template <TypeCategory CAT, int KIND, bool IS_MAX,
370 template <typename, bool, bool> class COMPARE, bool BACK>
371static RT_API_ATTRS void DoPartialMaxOrMinLocDirection(const char *intrinsic,
372 Descriptor &result, const Descriptor &x, int kind, int dim,
373 const Descriptor *mask, Terminator &terminator) {
374 using CppType = CppTypeFor<CAT, KIND>;
375 using Accumulator = ExtremumLocAccumulator<COMPARE<CppType, IS_MAX, BACK>>;
376 Accumulator accumulator{x};
377 ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, void>(
378 kind, terminator, result, x, dim, mask, terminator, intrinsic,
379 accumulator);
380}
381
382template <TypeCategory CAT, int KIND, bool IS_MAX,
383 template <typename, bool, bool> class COMPARE>
384inline RT_API_ATTRS void DoPartialMaxOrMinLoc(const char *intrinsic,
385 Descriptor &result, const Descriptor &x, int kind, int dim,
386 const Descriptor *mask, bool back, Terminator &terminator) {
387 if (back) {
388 DoPartialMaxOrMinLocDirection<CAT, KIND, IS_MAX, COMPARE, true>(
389 intrinsic, result, x, kind, dim, mask, terminator);
390 } else {
391 DoPartialMaxOrMinLocDirection<CAT, KIND, IS_MAX, COMPARE, false>(
392 intrinsic, result, x, kind, dim, mask, terminator);
393 }
394}
395
396template <TypeCategory CAT, bool IS_MAX,
397 template <typename, bool, bool> class COMPARE>
398struct DoPartialMaxOrMinLocHelper {
399 template <int KIND> struct Functor {
400 RT_API_ATTRS void operator()(const char *intrinsic, Descriptor &result,
401 const Descriptor &x, int kind, int dim, const Descriptor *mask,
402 bool back, Terminator &terminator) const {
403 DoPartialMaxOrMinLoc<CAT, KIND, IS_MAX, COMPARE>(
404 intrinsic, result, x, kind, dim, mask, back, terminator);
405 }
406 };
407};
408
409template <bool IS_MAX>
410inline RT_API_ATTRS void TypedPartialMaxOrMinLoc(const char *intrinsic,
411 Descriptor &result, const Descriptor &x, int kind, int dim,
412 const char *source, int line, const Descriptor *mask, bool back) {
413 Terminator terminator{source, line};
414 CheckIntegerKind(terminator, kind, intrinsic);
415 auto catKind{x.type().GetCategoryAndKind()};
416 RUNTIME_CHECK(terminator, catKind.has_value());
417 const Descriptor *maskToUse{mask};
418 SubscriptValue maskAt[maxRank]; // contents unused
419 if (mask && mask->rank() == 0) {
420 if (IsLogicalElementTrue(*mask, maskAt)) {
421 // A scalar MASK that's .TRUE. In this case, just get rid of the MASK.
422 maskToUse = nullptr;
423 } else {
424 // For scalar MASK arguments that are .FALSE., return all zeroes
425
426 // Element size of the destination descriptor is the size
427 // of {TypeCategory::Integer, kind}.
428 CreatePartialReductionResult(result, x,
429 Descriptor::BytesFor(TypeCategory::Integer, kind), dim, terminator,
430 intrinsic, TypeCode{TypeCategory::Integer, kind});
431 std::memset(
432 result.OffsetElement(), 0, result.Elements() * result.ElementBytes());
433 return;
434 }
435 }
436 switch (catKind->first) {
437 case TypeCategory::Integer:
438 ApplyIntegerKind<DoPartialMaxOrMinLocHelper<TypeCategory::Integer, IS_MAX,
439 NumericCompare>::template Functor,
440 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
441 maskToUse, back, terminator);
442 break;
443 case TypeCategory::Unsigned:
444 ApplyIntegerKind<DoPartialMaxOrMinLocHelper<TypeCategory::Unsigned, IS_MAX,
445 NumericCompare>::template Functor,
446 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
447 maskToUse, back, terminator);
448 break;
449 case TypeCategory::Real:
450 ApplyFloatingPointKind<DoPartialMaxOrMinLocHelper<TypeCategory::Real,
451 IS_MAX, NumericCompare>::template Functor,
452 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
453 maskToUse, back, terminator);
454 break;
455 case TypeCategory::Character:
456 ApplyCharacterKind<DoPartialMaxOrMinLocHelper<TypeCategory::Character,
457 IS_MAX, CharacterCompare>::template Functor,
458 void>(catKind->second, terminator, intrinsic, result, x, kind, dim,
459 maskToUse, back, terminator);
460 break;
461 default:
462 terminator.Crash(
463 "%s: bad data type code (%d) for array", intrinsic, x.type().raw());
464 }
465}
466
467extern "C" {
468RT_EXT_API_GROUP_BEGIN
469
470void RTDEF(MaxlocDim)(Descriptor &result, const Descriptor &x, int kind,
471 int dim, const char *source, int line, const Descriptor *mask, bool back) {
472 TypedPartialMaxOrMinLoc<true>(
473 "MAXLOC", result, x, kind, dim, source, line, mask, back);
474}
475void RTDEF(MinlocDim)(Descriptor &result, const Descriptor &x, int kind,
476 int dim, const char *source, int line, const Descriptor *mask, bool back) {
477 TypedPartialMaxOrMinLoc<false>(
478 "MINLOC", result, x, kind, dim, source, line, mask, back);
479}
480
481RT_EXT_API_GROUP_END
482} // extern "C"
483
484// MAXVAL and MINVAL
485
486template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
487class NumericExtremumAccumulator {
488public:
489 using Type = CppTypeFor<CAT, KIND>;
490 explicit RT_API_ATTRS NumericExtremumAccumulator(const Descriptor &array)
491 : array_{array} {}
492 RT_API_ATTRS void Reinitialize() {
493 any_ = false;
494 extremum_ = MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value();
495 }
496 template <typename A>
497 RT_API_ATTRS void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {
498 *p = extremum_;
499 }
500 RT_API_ATTRS bool Accumulate(Type x) {
501 if (!any_) {
502 extremum_ = x;
503 any_ = true;
504 } else if (CAT == TypeCategory::Real && extremum_ != extremum_) {
505 extremum_ = x; // replace NaN
506 } else if constexpr (IS_MAXVAL) {
507 if (x > extremum_) {
508 extremum_ = x;
509 }
510 } else if (x < extremum_) {
511 extremum_ = x;
512 }
513 return true;
514 }
515 template <typename A>
516 RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {
517 return Accumulate(*array_.Element<A>(at));
518 }
519
520private:
521 const Descriptor &array_;
522 bool any_{false};
523 Type extremum_{MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value()};
524};
525
526template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
527inline RT_API_ATTRS CppTypeFor<CAT, KIND> TotalNumericMaxOrMin(
528 const Descriptor &x, const char *source, int line, int dim,
529 const Descriptor *mask, const char *intrinsic) {
530 return GetTotalReduction<CAT, KIND>(x, source, line, dim, mask,
531 NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>{x}, intrinsic);
532}
533
534template <TypeCategory CAT, bool IS_MAXVAL> struct MaxOrMinHelper {
535 template <int KIND> struct Functor {
536 RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,
537 int dim, const Descriptor *mask, const char *intrinsic,
538 Terminator &terminator) const {
539 DoMaxMinNorm2<CAT, KIND,
540 NumericExtremumAccumulator<CAT, KIND, IS_MAXVAL>>(
541 result, x, dim, mask, intrinsic, terminator);
542 }
543 };
544};
545
546template <bool IS_MAXVAL>
547inline RT_API_ATTRS void NumericMaxOrMin(Descriptor &result,
548 const Descriptor &x, int dim, const char *source, int line,
549 const Descriptor *mask, const char *intrinsic) {
550 Terminator terminator{source, line};
551 auto type{x.type().GetCategoryAndKind()};
552 RUNTIME_CHECK(terminator, type);
553 switch (type->first) {
554 case TypeCategory::Integer:
555 ApplyIntegerKind<
556 MaxOrMinHelper<TypeCategory::Integer, IS_MAXVAL>::template Functor,
557 void>(
558 type->second, terminator, result, x, dim, mask, intrinsic, terminator);
559 break;
560 case TypeCategory::Unsigned:
561 ApplyIntegerKind<
562 MaxOrMinHelper<TypeCategory::Unsigned, IS_MAXVAL>::template Functor,
563 void>(
564 type->second, terminator, result, x, dim, mask, intrinsic, terminator);
565 break;
566 case TypeCategory::Real:
567 ApplyFloatingPointKind<
568 MaxOrMinHelper<TypeCategory::Real, IS_MAXVAL>::template Functor, void>(
569 type->second, terminator, result, x, dim, mask, intrinsic, terminator);
570 break;
571 default:
572 terminator.Crash("%s: bad type code %d", intrinsic, x.type().raw());
573 }
574}
575
576template <int KIND, bool IS_MAXVAL> class CharacterExtremumAccumulator {
577public:
578 using Type = CppTypeFor<TypeCategory::Character, KIND>;
579 explicit RT_API_ATTRS CharacterExtremumAccumulator(const Descriptor &array)
580 : array_{array}, charLen_{array_.ElementBytes() / KIND} {}
581 RT_API_ATTRS void Reinitialize() { extremum_ = nullptr; }
582 template <typename A>
583 RT_API_ATTRS void GetResult(A *p, int /*zeroBasedDim*/ = -1) const {
584 static_assert(std::is_same_v<A, Type>);
585 std::size_t byteSize{array_.ElementBytes()};
586 if (extremum_) {
587 std::memcpy(p, extremum_, byteSize);
588 } else {
589 // Empty array; fill with character 0 for MAXVAL.
590 // For MINVAL, set all of the bits.
591 std::memset(p, IS_MAXVAL ? 0 : 255, byteSize);
592 }
593 }
594 RT_API_ATTRS bool Accumulate(const Type *x) {
595 if (!extremum_) {
596 extremum_ = x;
597 } else {
598 int cmp{CharacterScalarCompare(x, extremum_, charLen_, charLen_)};
599 if (IS_MAXVAL == (cmp > 0)) {
600 extremum_ = x;
601 }
602 }
603 return true;
604 }
605 template <typename A>
606 RT_API_ATTRS bool AccumulateAt(const SubscriptValue at[]) {
607 return Accumulate(array_.Element<A>(at));
608 }
609
610private:
611 const Descriptor &array_;
612 std::size_t charLen_;
613 const Type *extremum_{nullptr};
614};
615
616template <bool IS_MAXVAL> struct CharacterMaxOrMinHelper {
617 template <int KIND> struct Functor {
618 RT_API_ATTRS void operator()(Descriptor &result, const Descriptor &x,
619 int dim, const Descriptor *mask, const char *intrinsic,
620 Terminator &terminator) const {
621 DoMaxMinNorm2<TypeCategory::Character, KIND,
622 CharacterExtremumAccumulator<KIND, IS_MAXVAL>>(
623 result, x, dim, mask, intrinsic, terminator);
624 }
625 };
626};
627
628template <bool IS_MAXVAL>
629inline RT_API_ATTRS void CharacterMaxOrMin(Descriptor &result,
630 const Descriptor &x, int dim, const char *source, int line,
631 const Descriptor *mask, const char *intrinsic) {
632 Terminator terminator{source, line};
633 auto type{x.type().GetCategoryAndKind()};
634 RUNTIME_CHECK(terminator, type && type->first == TypeCategory::Character);
635 ApplyCharacterKind<CharacterMaxOrMinHelper<IS_MAXVAL>::template Functor,
636 void>(
637 type->second, terminator, result, x, dim, mask, intrinsic, terminator);
638}
639
640extern "C" {
641RT_EXT_API_GROUP_BEGIN
642
643CppTypeFor<TypeCategory::Integer, 1> RTDEF(MaxvalInteger1)(const Descriptor &x,
644 const char *source, int line, int dim, const Descriptor *mask) {
645 return TotalNumericMaxOrMin<TypeCategory::Integer, 1, true>(
646 x, source, line, dim, mask, "MAXVAL");
647}
648CppTypeFor<TypeCategory::Integer, 2> RTDEF(MaxvalInteger2)(const Descriptor &x,
649 const char *source, int line, int dim, const Descriptor *mask) {
650 return TotalNumericMaxOrMin<TypeCategory::Integer, 2, true>(
651 x, source, line, dim, mask, "MAXVAL");
652}
653CppTypeFor<TypeCategory::Integer, 4> RTDEF(MaxvalInteger4)(const Descriptor &x,
654 const char *source, int line, int dim, const Descriptor *mask) {
655 return TotalNumericMaxOrMin<TypeCategory::Integer, 4, true>(
656 x, source, line, dim, mask, "MAXVAL");
657}
658CppTypeFor<TypeCategory::Integer, 8> RTDEF(MaxvalInteger8)(const Descriptor &x,
659 const char *source, int line, int dim, const Descriptor *mask) {
660 return TotalNumericMaxOrMin<TypeCategory::Integer, 8, true>(
661 x, source, line, dim, mask, "MAXVAL");
662}
663#ifdef __SIZEOF_INT128__
664CppTypeFor<TypeCategory::Integer, 16> RTDEF(MaxvalInteger16)(
665 const Descriptor &x, const char *source, int line, int dim,
666 const Descriptor *mask) {
667 return TotalNumericMaxOrMin<TypeCategory::Integer, 16, true>(
668 x, source, line, dim, mask, "MAXVAL");
669}
670#endif
671
672CppTypeFor<TypeCategory::Unsigned, 1> RTDEF(MaxvalUnsigned1)(
673 const Descriptor &x, const char *source, int line, int dim,
674 const Descriptor *mask) {
675 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 1, true>(
676 x, source, line, dim, mask, "MAXVAL");
677}
678CppTypeFor<TypeCategory::Unsigned, 2> RTDEF(MaxvalUnsigned2)(
679 const Descriptor &x, const char *source, int line, int dim,
680 const Descriptor *mask) {
681 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 2, true>(
682 x, source, line, dim, mask, "MAXVAL");
683}
684CppTypeFor<TypeCategory::Unsigned, 4> RTDEF(MaxvalUnsigned4)(
685 const Descriptor &x, const char *source, int line, int dim,
686 const Descriptor *mask) {
687 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 4, true>(
688 x, source, line, dim, mask, "MAXVAL");
689}
690CppTypeFor<TypeCategory::Unsigned, 8> RTDEF(MaxvalUnsigned8)(
691 const Descriptor &x, const char *source, int line, int dim,
692 const Descriptor *mask) {
693 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 8, true>(
694 x, source, line, dim, mask, "MAXVAL");
695}
696#ifdef __SIZEOF_INT128__
697CppTypeFor<TypeCategory::Unsigned, 16> RTDEF(MaxvalUnsigned16)(
698 const Descriptor &x, const char *source, int line, int dim,
699 const Descriptor *mask) {
700 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 16, true>(
701 x, source, line, dim, mask, "MAXVAL");
702}
703#endif
704
705// TODO: REAL(2 & 3)
706CppTypeFor<TypeCategory::Real, 4> RTDEF(MaxvalReal4)(const Descriptor &x,
707 const char *source, int line, int dim, const Descriptor *mask) {
708 return TotalNumericMaxOrMin<TypeCategory::Real, 4, true>(
709 x, source, line, dim, mask, "MAXVAL");
710}
711CppTypeFor<TypeCategory::Real, 8> RTDEF(MaxvalReal8)(const Descriptor &x,
712 const char *source, int line, int dim, const Descriptor *mask) {
713 return TotalNumericMaxOrMin<TypeCategory::Real, 8, true>(
714 x, source, line, dim, mask, "MAXVAL");
715}
716#if HAS_FLOAT80
717CppTypeFor<TypeCategory::Real, 10> RTDEF(MaxvalReal10)(const Descriptor &x,
718 const char *source, int line, int dim, const Descriptor *mask) {
719 return TotalNumericMaxOrMin<TypeCategory::Real, 10, true>(
720 x, source, line, dim, mask, "MAXVAL");
721}
722#endif
723#if HAS_LDBL128 || HAS_FLOAT128
724CppTypeFor<TypeCategory::Real, 16> RTDEF(MaxvalReal16)(const Descriptor &x,
725 const char *source, int line, int dim, const Descriptor *mask) {
726 return TotalNumericMaxOrMin<TypeCategory::Real, 16, true>(
727 x, source, line, dim, mask, "MAXVAL");
728}
729#endif
730
731void RTDEF(MaxvalCharacter)(Descriptor &result, const Descriptor &x,
732 const char *source, int line, const Descriptor *mask) {
733 CharacterMaxOrMin<true>(result, x, 0, source, line, mask, "MAXVAL");
734}
735
736CppTypeFor<TypeCategory::Integer, 1> RTDEF(MinvalInteger1)(const Descriptor &x,
737 const char *source, int line, int dim, const Descriptor *mask) {
738 return TotalNumericMaxOrMin<TypeCategory::Integer, 1, false>(
739 x, source, line, dim, mask, "MINVAL");
740}
741CppTypeFor<TypeCategory::Integer, 2> RTDEF(MinvalInteger2)(const Descriptor &x,
742 const char *source, int line, int dim, const Descriptor *mask) {
743 return TotalNumericMaxOrMin<TypeCategory::Integer, 2, false>(
744 x, source, line, dim, mask, "MINVAL");
745}
746CppTypeFor<TypeCategory::Integer, 4> RTDEF(MinvalInteger4)(const Descriptor &x,
747 const char *source, int line, int dim, const Descriptor *mask) {
748 return TotalNumericMaxOrMin<TypeCategory::Integer, 4, false>(
749 x, source, line, dim, mask, "MINVAL");
750}
751CppTypeFor<TypeCategory::Integer, 8> RTDEF(MinvalInteger8)(const Descriptor &x,
752 const char *source, int line, int dim, const Descriptor *mask) {
753 return TotalNumericMaxOrMin<TypeCategory::Integer, 8, false>(
754 x, source, line, dim, mask, "MINVAL");
755}
756#ifdef __SIZEOF_INT128__
757CppTypeFor<TypeCategory::Integer, 16> RTDEF(MinvalInteger16)(
758 const Descriptor &x, const char *source, int line, int dim,
759 const Descriptor *mask) {
760 return TotalNumericMaxOrMin<TypeCategory::Integer, 16, false>(
761 x, source, line, dim, mask, "MINVAL");
762}
763#endif
764
765CppTypeFor<TypeCategory::Unsigned, 1> RTDEF(MinvalUnsigned1)(
766 const Descriptor &x, const char *source, int line, int dim,
767 const Descriptor *mask) {
768 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 1, false>(
769 x, source, line, dim, mask, "MINVAL");
770}
771CppTypeFor<TypeCategory::Unsigned, 2> RTDEF(MinvalUnsigned2)(
772 const Descriptor &x, const char *source, int line, int dim,
773 const Descriptor *mask) {
774 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 2, false>(
775 x, source, line, dim, mask, "MINVAL");
776}
777CppTypeFor<TypeCategory::Unsigned, 4> RTDEF(MinvalUnsigned4)(
778 const Descriptor &x, const char *source, int line, int dim,
779 const Descriptor *mask) {
780 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 4, false>(
781 x, source, line, dim, mask, "MINVAL");
782}
783CppTypeFor<TypeCategory::Unsigned, 8> RTDEF(MinvalUnsigned8)(
784 const Descriptor &x, const char *source, int line, int dim,
785 const Descriptor *mask) {
786 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 8, false>(
787 x, source, line, dim, mask, "MINVAL");
788}
789#ifdef __SIZEOF_INT128__
790CppTypeFor<TypeCategory::Unsigned, 16> RTDEF(MinvalUnsigned16)(
791 const Descriptor &x, const char *source, int line, int dim,
792 const Descriptor *mask) {
793 return TotalNumericMaxOrMin<TypeCategory::Unsigned, 16, false>(
794 x, source, line, dim, mask, "MINVAL");
795}
796#endif
797
798// TODO: REAL(2 & 3)
799CppTypeFor<TypeCategory::Real, 4> RTDEF(MinvalReal4)(const Descriptor &x,
800 const char *source, int line, int dim, const Descriptor *mask) {
801 return TotalNumericMaxOrMin<TypeCategory::Real, 4, false>(
802 x, source, line, dim, mask, "MINVAL");
803}
804CppTypeFor<TypeCategory::Real, 8> RTDEF(MinvalReal8)(const Descriptor &x,
805 const char *source, int line, int dim, const Descriptor *mask) {
806 return TotalNumericMaxOrMin<TypeCategory::Real, 8, false>(
807 x, source, line, dim, mask, "MINVAL");
808}
809#if HAS_FLOAT80
810CppTypeFor<TypeCategory::Real, 10> RTDEF(MinvalReal10)(const Descriptor &x,
811 const char *source, int line, int dim, const Descriptor *mask) {
812 return TotalNumericMaxOrMin<TypeCategory::Real, 10, false>(
813 x, source, line, dim, mask, "MINVAL");
814}
815#endif
816#if HAS_LDBL128 || HAS_FLOAT128
817CppTypeFor<TypeCategory::Real, 16> RTDEF(MinvalReal16)(const Descriptor &x,
818 const char *source, int line, int dim, const Descriptor *mask) {
819 return TotalNumericMaxOrMin<TypeCategory::Real, 16, false>(
820 x, source, line, dim, mask, "MINVAL");
821}
822#endif
823
824void RTDEF(MinvalCharacter)(Descriptor &result, const Descriptor &x,
825 const char *source, int line, const Descriptor *mask) {
826 CharacterMaxOrMin<false>(result, x, 0, source, line, mask, "MINVAL");
827}
828
829void RTDEF(MaxvalDim)(Descriptor &result, const Descriptor &x, int dim,
830 const char *source, int line, const Descriptor *mask) {
831 if (x.type().IsCharacter()) {
832 CharacterMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL");
833 } else {
834 NumericMaxOrMin<true>(result, x, dim, source, line, mask, "MAXVAL");
835 }
836}
837void RTDEF(MinvalDim)(Descriptor &result, const Descriptor &x, int dim,
838 const char *source, int line, const Descriptor *mask) {
839 if (x.type().IsCharacter()) {
840 CharacterMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL");
841 } else {
842 NumericMaxOrMin<false>(result, x, dim, source, line, mask, "MINVAL");
843 }
844}
845
846RT_EXT_API_GROUP_END
847} // extern "C"
848
849// NORM2
850
851extern "C" {
852RT_EXT_API_GROUP_BEGIN
853
854// TODO: REAL(2 & 3)
855CppTypeFor<TypeCategory::Real, 4> RTDEF(Norm2_4)(
856 const Descriptor &x, const char *source, int line, int dim) {
857 return GetTotalReduction<TypeCategory::Real, 4>(
858 x, source, line, dim, nullptr, Norm2Accumulator<4>{x}, "NORM2");
859}
860CppTypeFor<TypeCategory::Real, 8> RTDEF(Norm2_8)(
861 const Descriptor &x, const char *source, int line, int dim) {
862 return GetTotalReduction<TypeCategory::Real, 8>(
863 x, source, line, dim, nullptr, Norm2Accumulator<8>{x}, "NORM2");
864}
865#if HAS_FLOAT80
866CppTypeFor<TypeCategory::Real, 10> RTDEF(Norm2_10)(
867 const Descriptor &x, const char *source, int line, int dim) {
868 return GetTotalReduction<TypeCategory::Real, 10>(
869 x, source, line, dim, nullptr, Norm2Accumulator<10>{x}, "NORM2");
870}
871#endif
872
873void RTDEF(Norm2Dim)(Descriptor &result, const Descriptor &x, int dim,
874 const char *source, int line) {
875 Terminator terminator{source, line};
876 auto type{x.type().GetCategoryAndKind()};
877 RUNTIME_CHECK(terminator, type);
878 if (type->first == TypeCategory::Real) {
879 ApplyFloatingPointKind<Norm2Helper, void, true>(
880 type->second, terminator, result, x, dim, nullptr, terminator);
881 } else {
882 terminator.Crash("NORM2: bad type code %d", x.type().raw());
883 }
884}
885
886RT_EXT_API_GROUP_END
887} // extern "C"
888} // namespace Fortran::runtime
889

source code of flang-rt/lib/runtime/extrema.cpp