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
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()}) {
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()}) {
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(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}
234void 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
240void 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
247void 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
253void 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}
258void 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}
263void 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}
268void 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}
273void 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__
279void 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
285void 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}
290void 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
296void 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
303void 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
310RT_EXT_API_GROUP_END
311} // extern "C"
312
313// MAXLOC/MINLOC with DIM=
314
315template <TypeCategory CAT, int KIND, bool IS_MAX,
316 template <typename, bool, bool> class COMPARE, bool BACK>
317static 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
328template <TypeCategory CAT, int KIND, bool IS_MAX,
329 template <typename, bool, bool> class COMPARE>
330inline 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
342template <TypeCategory CAT, bool IS_MAX,
343 template <typename, bool, bool> class COMPARE>
344struct 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
355template <bool IS_MAX>
356inline 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 s: result.OffsetElement(), c: 0, n: 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
407extern "C" {
408RT_EXT_API_GROUP_BEGIN
409
410void 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}
415void 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
421RT_EXT_API_GROUP_END
422} // extern "C"
423
424// MAXVAL and MINVAL
425
426template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
427class NumericExtremumAccumulator {
428public:
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
460private:
461 const Descriptor &array_;
462 bool any_{false};
463 Type extremum_{MaxOrMinIdentity<CAT, KIND, IS_MAXVAL>::Value()};
464};
465
466template <TypeCategory CAT, int KIND, bool IS_MAXVAL>
467inline 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
474template <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
486template <bool IS_MAXVAL>
487inline 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
510template <int KIND, bool IS_MAXVAL> class CharacterExtremumAccumulator {
511public:
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(s: p, c: IS_MAXVAL ? 0 : 255, n: 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
544private:
545 const Descriptor &array_;
546 std::size_t charLen_;
547 const Type *extremum_{nullptr};
548};
549
550template <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
562template <bool IS_MAXVAL>
563inline 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
574extern "C" {
575RT_EXT_API_GROUP_BEGIN
576
577CppTypeFor<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}
582CppTypeFor<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}
587CppTypeFor<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}
592CppTypeFor<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__
598CppTypeFor<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)
607CppTypeFor<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}
612CppTypeFor<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
618CppTypeFor<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
625CppTypeFor<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
632void 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
637CppTypeFor<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}
642CppTypeFor<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}
647CppTypeFor<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}
652CppTypeFor<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__
658CppTypeFor<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)
667CppTypeFor<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}
672CppTypeFor<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
678CppTypeFor<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
685CppTypeFor<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
692void 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
697void 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}
705void 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
714RT_EXT_API_GROUP_END
715} // extern "C"
716
717// NORM2
718
719extern "C" {
720RT_EXT_API_GROUP_BEGIN
721
722// TODO: REAL(2 & 3)
723CppTypeFor<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}
728CppTypeFor<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
734CppTypeFor<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
741void 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
754RT_EXT_API_GROUP_END
755} // extern "C"
756} // namespace Fortran::runtime
757

source code of flang/runtime/extrema.cpp