flang/runtime/extrema.cpp

   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 HAS_FLOAT80
 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 HAS_LDBL128 || 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 HAS_FLOAT80
 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 HAS_LDBL128 || 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 HAS_FLOAT80
 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 HAS_LDBL128 || 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 HAS_FLOAT80
 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 HAS_LDBL128 || 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 HAS_FLOAT80
 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