Index: flang/include/flang/Evaluate/characteristics.h
===================================================================
--- flang/include/flang/Evaluate/characteristics.h
+++ flang/include/flang/Evaluate/characteristics.h
@@ -81,23 +81,24 @@
   bool operator!=(const TypeAndShape &that) const { return !(*this == that); }
 
   static std::optional<TypeAndShape> Characterize(
-      const semantics::Symbol &, FoldingContext &);
+      const semantics::Symbol &, FoldingContext &, bool invariantOnly = false);
   static std::optional<TypeAndShape> Characterize(
-      const semantics::DeclTypeSpec &, FoldingContext &);
+      const semantics::DeclTypeSpec &, FoldingContext &,
+      bool invariantOnly = false);
   static std::optional<TypeAndShape> Characterize(
-      const ActualArgument &, FoldingContext &);
+      const ActualArgument &, FoldingContext &, bool invariantOnly = false);
 
   // General case for Expr<T>, ActualArgument, &c.
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
-      const A &x, FoldingContext &context) {
+      const A &x, FoldingContext &context, bool invariantOnly = false) {
     if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) {
-      if (auto result{Characterize(*symbol, context)}) {
+      if (auto result{Characterize(*symbol, context, invariantOnly)}) {
         return result;
       }
     }
     if (auto type{x.GetType()}) {
-      TypeAndShape result{*type, GetShape(context, x)};
+      TypeAndShape result{*type, GetShape(context, x, invariantOnly)};
       if (type->category() == TypeCategory::Character) {
         if (const auto *chExpr{UnwrapExpr<Expr<SomeCharacter>>(x)}) {
           if (auto length{chExpr->LEN()}) {
@@ -114,14 +115,14 @@
   template <int KIND>
   static std::optional<TypeAndShape> Characterize(
       const Designator<Type<TypeCategory::Character, KIND>> &x,
-      FoldingContext &context) {
+      FoldingContext &context, bool invariantOnly = true) {
     if (const auto *symbol{UnwrapWholeSymbolOrComponentDataRef(x)}) {
-      if (auto result{Characterize(*symbol, context)}) {
+      if (auto result{Characterize(*symbol, context, invariantOnly)}) {
         return result;
       }
     }
     if (auto type{x.GetType()}) {
-      TypeAndShape result{*type, GetShape(context, x)};
+      TypeAndShape result{*type, GetShape(context, x, invariantOnly)};
       if (auto length{x.LEN()}) {
         result.set_LEN(std::move(*length));
       }
@@ -131,19 +132,19 @@
   }
 
   template <typename A>
-  static std::optional<TypeAndShape> Characterize(
-      const std::optional<A> &x, FoldingContext &context) {
+  static std::optional<TypeAndShape> Characterize(const std::optional<A> &x,
+      FoldingContext &context, bool invariantOnly = false) {
     if (x) {
-      return Characterize(*x, context);
+      return Characterize(*x, context, invariantOnly);
     } else {
       return std::nullopt;
     }
   }
   template <typename A>
   static std::optional<TypeAndShape> Characterize(
-      A *ptr, FoldingContext &context) {
+      A *ptr, FoldingContext &context, bool invariantOnly = false) {
     if (ptr) {
-      return Characterize(std::as_const(*ptr), context);
+      return Characterize(std::as_const(*ptr), context, invariantOnly);
     } else {
       return std::nullopt;
     }
@@ -181,7 +182,8 @@
 
 private:
   static std::optional<TypeAndShape> Characterize(
-      const semantics::AssocEntityDetails &, FoldingContext &);
+      const semantics::AssocEntityDetails &, FoldingContext &,
+      bool invariantOnly = true);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ProcEntityDetails &, FoldingContext &);
   void AcquireAttrs(const semantics::Symbol &);
Index: flang/include/flang/Evaluate/shape.h
===================================================================
--- flang/include/flang/Evaluate/shape.h
+++ flang/include/flang/Evaluate/shape.h
@@ -54,9 +54,14 @@
 Shape Fold(FoldingContext &, Shape &&);
 std::optional<Shape> Fold(FoldingContext &, std::optional<Shape> &&);
 
+// Computes shapes in terms of expressions that are scope-invariant, by
+// default, which is nearly always what one wants outside of procedure
+// characterization.
 template <typename A>
-std::optional<Shape> GetShape(FoldingContext &, const A &);
-template <typename A> std::optional<Shape> GetShape(const A &);
+std::optional<Shape> GetShape(
+    FoldingContext &, const A &, bool invariantOnly = true);
+template <typename A>
+std::optional<Shape> GetShape(const A &, bool invariantOnly = true);
 
 // The dimension argument to these inquiries is zero-based,
 // unlike the DIM= arguments to many intrinsics.
@@ -68,31 +73,42 @@
 // in those circumstances.
 // Similarly, GetUBOUND result will be forced to 0 on an empty dimension,
 // but will fail if the extent is not a compile time constant.
-ExtentExpr GetRawLowerBound(const NamedEntity &, int dimension);
 ExtentExpr GetRawLowerBound(
-    FoldingContext &, const NamedEntity &, int dimension);
-MaybeExtentExpr GetLBOUND(const NamedEntity &, int dimension);
-MaybeExtentExpr GetLBOUND(FoldingContext &, const NamedEntity &, int dimension);
-MaybeExtentExpr GetRawUpperBound(const NamedEntity &, int dimension);
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+ExtentExpr GetRawLowerBound(FoldingContext &, const NamedEntity &,
+    int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetLBOUND(
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetLBOUND(FoldingContext &, const NamedEntity &, int dimension,
+    bool invariantOnly = true);
 MaybeExtentExpr GetRawUpperBound(
-    FoldingContext &, const NamedEntity &, int dimension);
-MaybeExtentExpr GetUBOUND(const NamedEntity &, int dimension);
-MaybeExtentExpr GetUBOUND(FoldingContext &, const NamedEntity &, int dimension);
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetRawUpperBound(FoldingContext &, const NamedEntity &,
+    int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetUBOUND(
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetUBOUND(FoldingContext &, const NamedEntity &, int dimension,
+    bool invariantOnly = true);
 MaybeExtentExpr ComputeUpperBound(ExtentExpr &&lower, MaybeExtentExpr &&extent);
 MaybeExtentExpr ComputeUpperBound(
     FoldingContext &, ExtentExpr &&lower, MaybeExtentExpr &&extent);
-Shape GetRawLowerBounds(const NamedEntity &);
-Shape GetRawLowerBounds(FoldingContext &, const NamedEntity &);
-Shape GetLBOUNDs(const NamedEntity &);
-Shape GetLBOUNDs(FoldingContext &, const NamedEntity &);
-Shape GetUBOUNDs(const NamedEntity &);
-Shape GetUBOUNDs(FoldingContext &, const NamedEntity &);
-MaybeExtentExpr GetExtent(const NamedEntity &, int dimension);
-MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension);
-MaybeExtentExpr GetExtent(
-    const Subscript &, const NamedEntity &, int dimension);
+Shape GetRawLowerBounds(const NamedEntity &, bool invariantOnly = true);
+Shape GetRawLowerBounds(
+    FoldingContext &, const NamedEntity &, bool invariantOnly = true);
+Shape GetLBOUNDs(const NamedEntity &, bool invariantOnly = true);
+Shape GetLBOUNDs(
+    FoldingContext &, const NamedEntity &, bool invariantOnly = true);
+Shape GetUBOUNDs(const NamedEntity &, bool invariantOnly = true);
+Shape GetUBOUNDs(
+    FoldingContext &, const NamedEntity &, bool invariantOnly = true);
 MaybeExtentExpr GetExtent(
-    FoldingContext &, const Subscript &, const NamedEntity &, int dimension);
+    const NamedEntity &, int dimension, bool invariantOnly = true);
+MaybeExtentExpr GetExtent(FoldingContext &, const NamedEntity &, int dimension,
+    bool invariantOnly = true);
+MaybeExtentExpr GetExtent(const Subscript &, const NamedEntity &, int dimension,
+    bool invariantOnly = true);
+MaybeExtentExpr GetExtent(FoldingContext &, const Subscript &,
+    const NamedEntity &, int dimension, bool invariantOnly = true);
 
 // Compute an element count for a triplet or trip count for a DO.
 ExtentExpr CountTrips(
@@ -115,11 +131,14 @@
   using Result = std::optional<Shape>;
   using Base = AnyTraverse<GetShapeHelper, Result>;
   using Base::operator();
-  GetShapeHelper() : Base{*this} {}
-  explicit GetShapeHelper(FoldingContext &c) : Base{*this}, context_{&c} {}
-  explicit GetShapeHelper(FoldingContext &c, bool useResultSymbolShape)
-      : Base{*this}, context_{&c}, useResultSymbolShape_{useResultSymbolShape} {
-  }
+  explicit GetShapeHelper(bool invariantOnly)
+      : Base{*this}, invariantOnly_{invariantOnly} {}
+  explicit GetShapeHelper(FoldingContext &c, bool invariantOnly)
+      : Base{*this}, context_{&c}, invariantOnly_{invariantOnly} {}
+  explicit GetShapeHelper(
+      FoldingContext &c, bool useResultSymbolShape, bool invariantOnly)
+      : Base{*this}, context_{&c}, useResultSymbolShape_{useResultSymbolShape},
+        invariantOnly_{invariantOnly} {}
 
   Result operator()(const ImpliedDoIndex &) const { return ScalarShape(); }
   Result operator()(const DescriptorInquiry &) const { return ScalarShape(); }
@@ -160,7 +179,7 @@
   static Result ScalarShape() { return Shape{}; }
   static Shape ConstantShape(const Constant<ExtentType> &);
   Result AsShapeResult(ExtentExpr &&) const;
-  static Shape CreateShape(int rank, NamedEntity &);
+  Shape CreateShape(int rank, NamedEntity &) const;
 
   template <typename T>
   MaybeExtentExpr GetArrayConstructorValueExtent(
@@ -215,34 +234,40 @@
 
   FoldingContext *context_{nullptr};
   bool useResultSymbolShape_{true};
+  // When invariantOnly=false, the returned shape need not be invariant
+  // in its scope; in particular, it may contain references to dummy arguments.
+  bool invariantOnly_{true};
 };
 
 template <typename A>
-std::optional<Shape> GetShape(FoldingContext &context, const A &x) {
-  if (auto shape{GetShapeHelper{context}(x)}) {
+std::optional<Shape> GetShape(
+    FoldingContext &context, const A &x, bool invariantOnly) {
+  if (auto shape{GetShapeHelper{context, invariantOnly}(x)}) {
     return Fold(context, std::move(shape));
   } else {
     return std::nullopt;
   }
 }
 
-template <typename A> std::optional<Shape> GetShape(const A &x) {
-  return GetShapeHelper{}(x);
+template <typename A>
+std::optional<Shape> GetShape(const A &x, bool invariantOnly) {
+  return GetShapeHelper{invariantOnly}(x);
 }
 
 template <typename A>
-std::optional<Shape> GetShape(FoldingContext *context, const A &x) {
+std::optional<Shape> GetShape(
+    FoldingContext *context, const A &x, bool invariantOnly = true) {
   if (context) {
-    return GetShape(*context, x);
+    return GetShape(*context, x, invariantOnly);
   } else {
-    return GetShapeHelper{}(x);
+    return GetShapeHelper{invariantOnly}(x);
   }
 }
 
 template <typename A>
 std::optional<Constant<ExtentType>> GetConstantShape(
     FoldingContext &context, const A &x) {
-  if (auto shape{GetShape(context, x)}) {
+  if (auto shape{GetShape(context, x, /*invariantonly=*/true)}) {
     return AsConstantShape(context, *shape);
   } else {
     return std::nullopt;
@@ -252,7 +277,7 @@
 template <typename A>
 std::optional<ConstantSubscripts> GetConstantExtents(
     FoldingContext &context, const A &x) {
-  if (auto shape{GetShape(context, x)}) {
+  if (auto shape{GetShape(context, x, /*invariantOnly=*/true)}) {
     return AsConstantExtents(context, *shape);
   } else {
     return std::nullopt;
@@ -265,7 +290,8 @@
 // arguments).
 template <typename A>
 std::optional<Shape> GetContextFreeShape(FoldingContext &context, const A &x) {
-  return GetShapeHelper{context, false}(x);
+  return GetShapeHelper{
+      context, /*useResultSymbolShape=*/false, /*invariantOnly=*/true}(x);
 }
 
 // Compilation-time shape conformance checking, when corresponding extents
Index: flang/include/flang/Evaluate/tools.h
===================================================================
--- flang/include/flang/Evaluate/tools.h
+++ flang/include/flang/Evaluate/tools.h
@@ -1184,6 +1184,7 @@
 bool IsVariableName(const Symbol &);
 bool IsPureProcedure(const Symbol &);
 bool IsPureProcedure(const Scope &);
+bool IsExplicitlyImpureProcedure(const Symbol &);
 bool IsElementalProcedure(const Symbol &);
 bool IsFunction(const Symbol &);
 bool IsFunction(const Scope &);
Index: flang/lib/Evaluate/characteristics.cpp
===================================================================
--- flang/lib/Evaluate/characteristics.cpp
+++ flang/lib/Evaluate/characteristics.cpp
@@ -73,24 +73,26 @@
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::Symbol &symbol, FoldingContext &context) {
+    const semantics::Symbol &symbol, FoldingContext &context,
+    bool invariantOnly) {
   const auto &ultimate{symbol.GetUltimate()};
   return common::visit(
       common::visitors{
           [&](const semantics::ProcEntityDetails &proc) {
             if (proc.procInterface()) {
-              return Characterize(*proc.procInterface(), context);
+              return Characterize(
+                  *proc.procInterface(), context, invariantOnly);
             } else if (proc.type()) {
-              return Characterize(*proc.type(), context);
+              return Characterize(*proc.type(), context, invariantOnly);
             } else {
               return std::optional<TypeAndShape>{};
             }
           },
           [&](const semantics::AssocEntityDetails &assoc) {
-            return Characterize(assoc, context);
+            return Characterize(assoc, context, invariantOnly);
           },
           [&](const semantics::ProcBindingDetails &binding) {
-            return Characterize(binding.symbol(), context);
+            return Characterize(binding.symbol(), context, invariantOnly);
           },
           [&](const auto &x) -> std::optional<TypeAndShape> {
             using Ty = std::decay_t<decltype(x)>;
@@ -99,8 +101,8 @@
                 std::is_same_v<Ty, semantics::TypeParamDetails>) {
               if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
                 if (auto dyType{DynamicType::From(*type)}) {
-                  TypeAndShape result{
-                      std::move(*dyType), GetShape(context, ultimate)};
+                  TypeAndShape result{std::move(*dyType),
+                      GetShape(context, ultimate, invariantOnly)};
                   result.AcquireAttrs(ultimate);
                   result.AcquireLEN(ultimate);
                   return std::move(result.Rewrite(context));
@@ -117,14 +119,15 @@
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::AssocEntityDetails &assoc, FoldingContext &context) {
+    const semantics::AssocEntityDetails &assoc, FoldingContext &context,
+    bool invariantOnly) {
   std::optional<TypeAndShape> result;
   if (auto type{DynamicType::From(assoc.type())}) {
     if (auto rank{assoc.rank()}) {
       if (*rank >= 0 && *rank <= common::maxRank) {
         result = TypeAndShape{std::move(*type), Shape(*rank)};
       }
-    } else if (auto shape{GetShape(context, assoc.expr())}) {
+    } else if (auto shape{GetShape(context, assoc.expr(), invariantOnly)}) {
       result = TypeAndShape{std::move(*type), std::move(*shape)};
     }
     if (result && type->category() == TypeCategory::Character) {
@@ -139,7 +142,8 @@
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const semantics::DeclTypeSpec &spec, FoldingContext &context) {
+    const semantics::DeclTypeSpec &spec, FoldingContext &context,
+    bool /*invariantOnly=*/) {
   if (auto type{DynamicType::From(spec)}) {
     return Fold(context, TypeAndShape{std::move(*type)});
   } else {
@@ -148,11 +152,11 @@
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
-    const ActualArgument &arg, FoldingContext &context) {
+    const ActualArgument &arg, FoldingContext &context, bool invariantOnly) {
   if (const auto *expr{arg.UnwrapExpr()}) {
-    return Characterize(*expr, context);
+    return Characterize(*expr, context, invariantOnly);
   } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
-    return Characterize(*assumed, context);
+    return Characterize(*assumed, context, invariantOnly);
   } else {
     return std::nullopt;
   }
@@ -386,7 +390,8 @@
     const semantics::Symbol &symbol, FoldingContext &context) {
   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
       object || symbol.has<semantics::EntityDetails>()) {
-    if (auto type{TypeAndShape::Characterize(symbol, context)}) {
+    if (auto type{TypeAndShape::Characterize(
+            symbol, context, /*invariantOnly=*/false)}) {
       std::optional<DummyDataObject> result{std::move(*type)};
       using semantics::Attr;
       CopyAttrs<DummyDataObject, DummyDataObject::Attr>(symbol, *result,
@@ -525,7 +530,6 @@
 static std::optional<Procedure> CharacterizeProcedure(
     const semantics::Symbol &original, FoldingContext &context,
     semantics::UnorderedSymbolSet seenProcs) {
-  Procedure result;
   const auto &symbol{ResolveAssociations(original)};
   if (seenProcs.find(symbol) != seenProcs.end()) {
     std::string procsList{GetSeenProcs(seenProcs)};
@@ -536,22 +540,11 @@
     return std::nullopt;
   }
   seenProcs.insert(symbol);
-  if (IsElementalProcedure(symbol)) {
-    result.attrs.set(Procedure::Attr::Elemental);
-  }
-  CopyAttrs<Procedure, Procedure::Attr>(symbol, result,
-      {
-          {semantics::Attr::BIND_C, Procedure::Attr::BindC},
-      });
-  if (IsPureProcedure(symbol) || // works for ENTRY too
-      (!symbol.attrs().test(semantics::Attr::IMPURE) &&
-          result.attrs.test(Procedure::Attr::Elemental))) {
-    result.attrs.set(Procedure::Attr::Pure);
-  }
-  return common::visit(
+  auto result{common::visit(
       common::visitors{
           [&](const semantics::SubprogramDetails &subp)
               -> std::optional<Procedure> {
+            Procedure result;
             if (subp.isFunction()) {
               if (auto fr{CharacterizeFunctionResult(
                       subp.result(), context, seenProcs)}) {
@@ -578,7 +571,7 @@
               }
             }
             result.cudaSubprogramAttrs = subp.cudaSubprogramAttrs();
-            return result;
+            return std::move(result);
           },
           [&](const semantics::ProcEntityDetails &proc)
               -> std::optional<Procedure> {
@@ -597,14 +590,17 @@
             }
             if (const semantics::Symbol *
                 interfaceSymbol{proc.procInterface()}) {
-              auto interface {
-                CharacterizeProcedure(*interfaceSymbol, context, seenProcs)
-              };
-              if (interface && IsPointer(symbol)) {
-                interface->attrs.reset(Procedure::Attr::Elemental);
+              auto result{
+                  CharacterizeProcedure(*interfaceSymbol, context, seenProcs)};
+              if (result && (IsDummy(symbol) || IsPointer(symbol))) {
+                // Dummy procedures and procedure pointers may not be
+                // ELEMENTAL, but we do accept the use of elemental intrinsic
+                // functions as their interfaces.
+                result->attrs.reset(Procedure::Attr::Elemental);
               }
-              return interface;
+              return result;
             } else {
+              Procedure result;
               result.attrs.set(Procedure::Attr::ImplicitInterface);
               const semantics::DeclTypeSpec *type{proc.type()};
               if (symbol.test(semantics::Symbol::Flag::Subroutine)) {
@@ -624,7 +620,7 @@
                 return std::nullopt;
               }
               // The PASS name, if any, is not a characteristic.
-              return result;
+              return std::move(result);
             }
           },
           [&](const semantics::ProcBindingDetails &binding) {
@@ -683,7 +679,20 @@
             return std::optional<Procedure>{};
           },
       },
-      symbol.details());
+      symbol.details())};
+  if (result && !symbol.has<semantics::ProcBindingDetails>()) {
+    CopyAttrs<Procedure, Procedure::Attr>(DEREF(GetMainEntry(&symbol)), *result,
+        {
+            {semantics::Attr::BIND_C, Procedure::Attr::BindC},
+            {semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
+        });
+    if (IsPureProcedure(symbol) || // works for ENTRY too
+        (!IsExplicitlyImpureProcedure(symbol) &&
+            result->attrs.test(Procedure::Attr::Elemental))) {
+      result->attrs.set(Procedure::Attr::Pure);
+    }
+  }
+  return result;
 }
 
 static std::optional<DummyProcedure> CharacterizeDummyProcedure(
@@ -918,7 +927,8 @@
     const semantics::Symbol &symbol, FoldingContext &context,
     semantics::UnorderedSymbolSet seenProcs) {
   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (auto type{TypeAndShape::Characterize(symbol, context)}) {
+    if (auto type{TypeAndShape::Characterize(
+            symbol, context, /*invariantOnly=*/false)}) {
       FunctionResult result{std::move(*type)};
       CopyAttrs<FunctionResult, FunctionResult::Attr>(symbol, result,
           {
@@ -996,21 +1006,18 @@
   }
 }
 
-static bool AreCompatibleFunctionResultShapes(const Shape &x, const Shape &y) {
+static std::optional<std::string> AreIncompatibleFunctionResultShapes(
+    const Shape &x, const Shape &y) {
   int rank{GetRank(x)};
-  if (GetRank(y) != rank) {
-    return false;
+  if (int yrank{GetRank(y)}; yrank != rank) {
+    return "rank "s + std::to_string(rank) + " vs " + std::to_string(yrank);
   }
   for (int j{0}; j < rank; ++j) {
-    if (auto xDim{ToInt64(x[j])}) {
-      if (auto yDim{ToInt64(y[j])}) {
-        if (*xDim != *yDim) {
-          return false;
-        }
-      }
+    if (x[j] && y[j] && !(*x[j] == *y[j])) {
+      return x[j]->AsFortran() + " vs " + y[j]->AsFortran();
     }
   }
-  return true;
+  return std::nullopt;
 }
 
 bool FunctionResult::IsCompatibleWith(
@@ -1029,38 +1036,45 @@
     }
   } else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
     if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
+      std::optional<std::string> details;
       if (ifaceTypeShape->Rank() != actualTypeShape->Rank()) {
         if (whyNot) {
           *whyNot = "function results have distinct ranks";
         }
       } else if (!attrs.test(Attr::Allocatable) && !attrs.test(Attr::Pointer) &&
-          !AreCompatibleFunctionResultShapes(
-              ifaceTypeShape->shape(), actualTypeShape->shape())) {
+          (details = AreIncompatibleFunctionResultShapes(
+               ifaceTypeShape->shape(), actualTypeShape->shape()))) {
         if (whyNot) {
-          *whyNot = "function results have distinct constant extents";
+          *whyNot = "function results have distinct extents (" + *details + ')';
         }
       } else if (ifaceTypeShape->type() != actualTypeShape->type()) {
-        if (ifaceTypeShape->type().category() ==
+        if (ifaceTypeShape->type().category() !=
             actualTypeShape->type().category()) {
-          if (ifaceTypeShape->type().category() == TypeCategory::Character) {
-            if (ifaceTypeShape->type().kind() ==
-                actualTypeShape->type().kind()) {
-              auto ifaceLen{ifaceTypeShape->type().knownLength()};
-              auto actualLen{actualTypeShape->type().knownLength()};
-              if (!ifaceLen || !actualLen || *ifaceLen == *actualLen) {
+        } else if (ifaceTypeShape->type().category() ==
+            TypeCategory::Character) {
+          if (ifaceTypeShape->type().kind() == actualTypeShape->type().kind()) {
+            if (IsAssumedLengthCharacter() ||
+                actual.IsAssumedLengthCharacter()) {
+              return true;
+            } else {
+              const auto *ifaceLenParam{
+                  ifaceTypeShape->type().charLengthParamValue()};
+              const auto *actualLenParam{
+                  actualTypeShape->type().charLengthParamValue()};
+              if (ifaceLenParam && actualLenParam &&
+                  *ifaceLenParam == *actualLenParam) {
                 return true;
               }
             }
-          } else if (ifaceTypeShape->type().category() ==
-              TypeCategory::Derived) {
-            if (ifaceTypeShape->type().IsPolymorphic() ==
-                    actualTypeShape->type().IsPolymorphic() &&
-                !ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
-                !actualTypeShape->type().IsUnlimitedPolymorphic() &&
-                AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
-                    actualTypeShape->type().GetDerivedTypeSpec())) {
-              return true;
-            }
+          }
+        } else if (ifaceTypeShape->type().category() == TypeCategory::Derived) {
+          if (ifaceTypeShape->type().IsPolymorphic() ==
+                  actualTypeShape->type().IsPolymorphic() &&
+              !ifaceTypeShape->type().IsUnlimitedPolymorphic() &&
+              !actualTypeShape->type().IsUnlimitedPolymorphic() &&
+              AreSameDerivedType(ifaceTypeShape->type().GetDerivedTypeSpec(),
+                  actualTypeShape->type().GetDerivedTypeSpec())) {
+            return true;
           }
         }
         if (whyNot) {
Index: flang/lib/Evaluate/intrinsics.cpp
===================================================================
--- flang/lib/Evaluate/intrinsics.cpp
+++ flang/lib/Evaluate/intrinsics.cpp
@@ -3023,7 +3023,7 @@
           }
           if (!ok) {
             context.messages().Say(at,
-                "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional"_err_en_US);
+                "Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional"_err_en_US);
           } else if (data[0]->attrs.test(characteristics::DummyDataObject::
                              Attr::Asynchronous) !=
                   data[1]->attrs.test(
Index: flang/lib/Evaluate/shape.cpp
===================================================================
--- flang/lib/Evaluate/shape.cpp
+++ flang/lib/Evaluate/shape.cpp
@@ -76,10 +76,10 @@
   }
 }
 
-Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) {
+Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) const {
   Shape shape;
   for (int dimension{0}; dimension < rank; ++dimension) {
-    shape.emplace_back(GetExtent(base, dimension));
+    shape.emplace_back(GetExtent(base, dimension, invariantOnly_));
   }
   return shape;
 }
@@ -236,8 +236,10 @@
   using Result = RESULT;
   using Base = Traverse<GetLowerBoundHelper, RESULT>;
   using Base::operator();
-  explicit GetLowerBoundHelper(int d, FoldingContext *context)
-      : Base{*this}, dimension_{d}, context_{context} {}
+  explicit GetLowerBoundHelper(
+      int d, FoldingContext *context, bool invariantOnly)
+      : Base{*this}, dimension_{d}, context_{context}, invariantOnly_{
+                                                           invariantOnly} {}
   static Result Default() { return Result{1}; }
   static Result Combine(Result &&, Result &&) {
     // Operator results and array references always have lower bounds == 1
@@ -259,7 +261,7 @@
               if (dimension_ == rank - 1 && details->IsAssumedSize()) {
                 // last dimension of assumed-size dummy array: don't worry
                 // about handling an empty dimension
-                ok = IsScopeInvariantExpr(*lbound);
+                ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);
               } else if (lbValue.value_or(0) == 1) {
                 // Lower bound is 1, regardless of extent
                 ok = true;
@@ -371,60 +373,69 @@
 private:
   int dimension_; // zero-based
   FoldingContext *context_{nullptr};
+  bool invariantOnly_{false};
 };
 
-ExtentExpr GetRawLowerBound(const NamedEntity &base, int dimension) {
-  return GetLowerBoundHelper<ExtentExpr, false>{dimension, nullptr}(base);
+ExtentExpr GetRawLowerBound(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return GetLowerBoundHelper<ExtentExpr, false>{
+      dimension, nullptr, invariantOnly}(base);
 }
 
-ExtentExpr GetRawLowerBound(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
+ExtentExpr GetRawLowerBound(FoldingContext &context, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
   return Fold(context,
-      GetLowerBoundHelper<ExtentExpr, false>{dimension, &context}(base));
+      GetLowerBoundHelper<ExtentExpr, false>{
+          dimension, &context, invariantOnly}(base));
 }
 
-MaybeExtentExpr GetLBOUND(const NamedEntity &base, int dimension) {
-  return GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, nullptr}(base);
+MaybeExtentExpr GetLBOUND(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return GetLowerBoundHelper<MaybeExtentExpr, true>{
+      dimension, nullptr, invariantOnly}(base);
 }
 
-MaybeExtentExpr GetLBOUND(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetLBOUND(FoldingContext &context, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
   return Fold(context,
-      GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, &context}(base));
+      GetLowerBoundHelper<MaybeExtentExpr, true>{
+          dimension, &context, invariantOnly}(base));
 }
 
-Shape GetRawLowerBounds(const NamedEntity &base) {
+Shape GetRawLowerBounds(const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetRawLowerBound(base, dim));
+    result.emplace_back(GetRawLowerBound(base, dim, invariantOnly));
   }
   return result;
 }
 
-Shape GetRawLowerBounds(FoldingContext &context, const NamedEntity &base) {
+Shape GetRawLowerBounds(
+    FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetRawLowerBound(context, base, dim));
+    result.emplace_back(GetRawLowerBound(context, base, dim, invariantOnly));
   }
   return result;
 }
 
-Shape GetLBOUNDs(const NamedEntity &base) {
+Shape GetLBOUNDs(const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetLBOUND(base, dim));
+    result.emplace_back(GetLBOUND(base, dim, invariantOnly));
   }
   return result;
 }
 
-Shape GetLBOUNDs(FoldingContext &context, const NamedEntity &base) {
+Shape GetLBOUNDs(
+    FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetLBOUND(context, base, dim));
+    result.emplace_back(GetLBOUND(context, base, dim, invariantOnly));
   }
   return result;
 }
@@ -433,7 +444,7 @@
 // the extent.  In particular, if the upper bound is less than the lower bound,
 // return zero.
 static MaybeExtentExpr GetNonNegativeExtent(
-    const semantics::ShapeSpec &shapeSpec) {
+    const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
   const auto &ubound{shapeSpec.ubound().GetExplicit()};
   const auto &lbound{shapeSpec.lbound().GetExplicit()};
   std::optional<ConstantSubscript> uval{ToInt64(ubound)};
@@ -444,8 +455,9 @@
     } else {
       return ExtentExpr{*uval - *lval + 1};
     }
-  } else if (lbound && ubound && IsScopeInvariantExpr(*lbound) &&
-      IsScopeInvariantExpr(*ubound)) {
+  } else if (lbound && ubound &&
+      (!invariantOnly ||
+          (IsScopeInvariantExpr(*lbound) && IsScopeInvariantExpr(*ubound)))) {
     // Apply effective IDIM (MAX calculation with 0) so thet the
     // result is never negative
     if (lval.value_or(0) == 1) {
@@ -481,7 +493,8 @@
   return std::nullopt;
 }
 
-MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetExtent(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
   CHECK(dimension >= 0);
   const Symbol &last{base.GetLastSymbol()};
   const Symbol &symbol{ResolveAssociationsExceptSelectRank(last)};
@@ -506,7 +519,7 @@
       int j{0};
       for (const auto &shapeSpec : details->shape()) {
         if (j++ == dimension) {
-          if (auto extent{GetNonNegativeExtent(shapeSpec)}) {
+          if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
             return extent;
           } else if (details->IsAssumedSize() && j == symbol.Rank()) {
             return std::nullopt;
@@ -523,23 +536,23 @@
   return std::nullopt;
 }
 
-MaybeExtentExpr GetExtent(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
-  return Fold(context, GetExtent(base, dimension));
+MaybeExtentExpr GetExtent(FoldingContext &context, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
+  return Fold(context, GetExtent(base, dimension, invariantOnly));
 }
 
-MaybeExtentExpr GetExtent(
-    const Subscript &subscript, const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetExtent(const Subscript &subscript, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
   return common::visit(
       common::visitors{
           [&](const Triplet &triplet) -> MaybeExtentExpr {
             MaybeExtentExpr upper{triplet.upper()};
             if (!upper) {
-              upper = GetUBOUND(base, dimension);
+              upper = GetUBOUND(base, dimension, invariantOnly);
             }
             MaybeExtentExpr lower{triplet.lower()};
             if (!lower) {
-              lower = GetLBOUND(base, dimension);
+              lower = GetLBOUND(base, dimension, invariantOnly);
             }
             return CountTrips(std::move(lower), std::move(upper),
                 MaybeExtentExpr{triplet.stride()});
@@ -558,8 +571,8 @@
 }
 
 MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
-    const NamedEntity &base, int dimension) {
-  return Fold(context, GetExtent(subscript, base, dimension));
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return Fold(context, GetExtent(subscript, base, dimension, invariantOnly));
 }
 
 MaybeExtentExpr ComputeUpperBound(
@@ -580,14 +593,15 @@
   return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));
 }
 
-MaybeExtentExpr GetRawUpperBound(const NamedEntity &base, int dimension) {
+MaybeExtentExpr GetRawUpperBound(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
   const Symbol &symbol{
       ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int rank{details->shape().Rank()};
     if (dimension < rank) {
       const auto &bound{details->shape()[dimension].ubound().GetExplicit()};
-      if (bound && IsScopeInvariantExpr(*bound)) {
+      if (bound && (!invariantOnly || IsScopeInvariantExpr(*bound))) {
         return *bound;
       } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
         return std::nullopt;
@@ -606,16 +620,16 @@
   return std::nullopt;
 }
 
-MaybeExtentExpr GetRawUpperBound(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
-  return Fold(context, GetRawUpperBound(base, dimension));
+MaybeExtentExpr GetRawUpperBound(FoldingContext &context,
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return Fold(context, GetRawUpperBound(base, dimension, invariantOnly));
 }
 
-static MaybeExtentExpr GetExplicitUBOUND(
-    FoldingContext *context, const semantics::ShapeSpec &shapeSpec) {
+static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,
+    const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
   const auto &ubound{shapeSpec.ubound().GetExplicit()};
-  if (ubound && IsScopeInvariantExpr(*ubound)) {
-    if (auto extent{GetNonNegativeExtent(shapeSpec)}) {
+  if (ubound && (!invariantOnly || IsScopeInvariantExpr(*ubound))) {
+    if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
       if (auto cstExtent{ToInt64(
               context ? Fold(*context, std::move(*extent)) : *extent)}) {
         if (cstExtent > 0) {
@@ -629,20 +643,21 @@
   return std::nullopt;
 }
 
-static MaybeExtentExpr GetUBOUND(
-    FoldingContext *context, const NamedEntity &base, int dimension) {
+static MaybeExtentExpr GetUBOUND(FoldingContext *context,
+    const NamedEntity &base, int dimension, bool invariantOnly) {
   const Symbol &symbol{
       ResolveAssociationsExceptSelectRank(base.GetLastSymbol())};
   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
     int rank{details->shape().Rank()};
     if (dimension < rank) {
       const semantics::ShapeSpec &shapeSpec{details->shape()[dimension]};
-      if (auto ubound{GetExplicitUBOUND(context, shapeSpec)}) {
+      if (auto ubound{GetExplicitUBOUND(context, shapeSpec, invariantOnly)}) {
         return *ubound;
       } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
         return std::nullopt; // UBOUND() folding replaces with -1
-      } else if (auto lb{GetLBOUND(base, dimension)}) {
-        return ComputeUpperBound(std::move(*lb), GetExtent(base, dimension));
+      } else if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
+        return ComputeUpperBound(
+            std::move(*lb), GetExtent(base, dimension, invariantOnly));
       }
     }
   } else if (const auto *assoc{
@@ -658,7 +673,7 @@
       }
     } else if (assoc->expr()) {
       if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) {
-        if (auto lb{GetLBOUND(base, dimension)}) {
+        if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
           return ComputeUpperBound(std::move(*lb), std::move(extent));
         }
       }
@@ -667,29 +682,34 @@
   return std::nullopt;
 }
 
-MaybeExtentExpr GetUBOUND(const NamedEntity &base, int dimension) {
-  return GetUBOUND(nullptr, base, dimension);
+MaybeExtentExpr GetUBOUND(
+    const NamedEntity &base, int dimension, bool invariantOnly) {
+  return GetUBOUND(nullptr, base, dimension, invariantOnly);
 }
 
-MaybeExtentExpr GetUBOUND(
-    FoldingContext &context, const NamedEntity &base, int dimension) {
-  return Fold(context, GetUBOUND(&context, base, dimension));
+MaybeExtentExpr GetUBOUND(FoldingContext &context, const NamedEntity &base,
+    int dimension, bool invariantOnly) {
+  return Fold(context, GetUBOUND(&context, base, dimension, invariantOnly));
 }
 
-static Shape GetUBOUNDs(FoldingContext *context, const NamedEntity &base) {
+static Shape GetUBOUNDs(
+    FoldingContext *context, const NamedEntity &base, bool invariantOnly) {
   Shape result;
   int rank{base.Rank()};
   for (int dim{0}; dim < rank; ++dim) {
-    result.emplace_back(GetUBOUND(context, base, dim));
+    result.emplace_back(GetUBOUND(context, base, dim, invariantOnly));
   }
   return result;
 }
 
-Shape GetUBOUNDs(FoldingContext &context, const NamedEntity &base) {
-  return Fold(context, GetUBOUNDs(&context, base));
+Shape GetUBOUNDs(
+    FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
+  return Fold(context, GetUBOUNDs(&context, base, invariantOnly));
 }
 
-Shape GetUBOUNDs(const NamedEntity &base) { return GetUBOUNDs(nullptr, base); }
+Shape GetUBOUNDs(const NamedEntity &base, bool invariantOnly) {
+  return GetUBOUNDs(nullptr, base, invariantOnly);
+}
 
 auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
   return common::visit(
Index: flang/lib/Evaluate/tools.cpp
===================================================================
--- flang/lib/Evaluate/tools.cpp
+++ flang/lib/Evaluate/tools.cpp
@@ -1323,23 +1323,26 @@
   return symbol && IsPureProcedure(*symbol);
 }
 
+bool IsExplicitlyImpureProcedure(const Symbol &original) {
+  // An ENTRY is IMPURE if its containing subprogram is so
+  return DEREF(GetMainEntry(&original.GetUltimate()))
+      .attrs()
+      .test(Attr::IMPURE);
+}
+
 bool IsElementalProcedure(const Symbol &original) {
   // An ENTRY is elemental if its containing subprogram is
   const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
-  if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
-    if (const Symbol * procInterface{procDetails->procInterface()}) {
-      // procedure with an elemental interface, ignoring the elemental
-      // aspect of intrinsic functions
-      return !procInterface->attrs().test(Attr::INTRINSIC) &&
-          IsElementalProcedure(*procInterface);
-    }
-  } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
-    return !details->symbol().attrs().test(Attr::INTRINSIC) &&
-        IsElementalProcedure(details->symbol());
-  } else if (!IsProcedure(symbol)) {
+  if (IsProcedure(symbol)) {
+    auto &foldingContext{symbol.owner().context().foldingContext()};
+    auto restorer{foldingContext.messages().DiscardMessages()};
+    auto proc{evaluate::characteristics::Procedure::Characterize(
+        symbol, foldingContext)};
+    return proc &&
+        proc->attrs.test(evaluate::characteristics::Procedure::Attr::Elemental);
+  } else {
     return false;
   }
-  return symbol.attrs().test(Attr::ELEMENTAL);
 }
 
 bool IsFunction(const Symbol &symbol) {
Index: flang/lib/Evaluate/variable.cpp
===================================================================
--- flang/lib/Evaluate/variable.cpp
+++ flang/lib/Evaluate/variable.cpp
@@ -639,16 +639,32 @@
 
 // For the purposes of comparing type parameter expressions while
 // testing the compatibility of procedure characteristics, two
-// object dummy arguments with the same name are considered equal.
+// dummy arguments with the same position are considered equal.
+static std::optional<int> GetDummyArgPosition(const Symbol &original) {
+  const Symbol &symbol(original.GetUltimate());
+  if (IsDummy(symbol)) {
+    if (const Symbol * proc{symbol.owner().symbol()}) {
+      if (const auto *subp{proc->detailsIf<semantics::SubprogramDetails>()}) {
+        int j{0};
+        for (const Symbol *arg : subp->dummyArgs()) {
+          if (arg == &symbol) {
+            return j;
+          }
+          ++j;
+        }
+      }
+    }
+  }
+  return std::nullopt;
+}
+
 static bool AreSameSymbol(const Symbol &x, const Symbol &y) {
   if (&x == &y) {
     return true;
   }
-  if (x.name() == y.name()) {
-    if (const auto *xObject{x.detailsIf<semantics::ObjectEntityDetails>()}) {
-      if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
-        return xObject->isDummy() && yObject->isDummy();
-      }
+  if (auto xPos{GetDummyArgPosition(x)}) {
+    if (auto yPos{GetDummyArgPosition(y)}) {
+      return *xPos == *yPos;
     }
   }
   return false;
Index: flang/lib/Lower/ConvertType.cpp
===================================================================
--- flang/lib/Lower/ConvertType.cpp
+++ flang/lib/Lower/ConvertType.cpp
@@ -276,8 +276,8 @@
                           Fortran::semantics::IsUnlimitedPolymorphic(symbol)) &&
                          !Fortran::semantics::IsAssumedType(symbol);
     if (ultimate.IsObjectArray()) {
-      auto shapeExpr = Fortran::evaluate::GetShapeHelper{
-          converter.getFoldingContext()}(ultimate);
+      auto shapeExpr =
+          Fortran::evaluate::GetShape(converter.getFoldingContext(), ultimate);
       if (!shapeExpr)
         TODO(loc, "assumed rank symbol type");
       fir::SequenceType::Shape shape;
Index: flang/lib/Semantics/check-declarations.cpp
===================================================================
--- flang/lib/Semantics/check-declarations.cpp
+++ flang/lib/Semantics/check-declarations.cpp
@@ -1024,7 +1024,7 @@
         if (auto designator{evaluate::AsGenericExpr(symbol)}) {
           auto restorer{messages_.SetLocation(symbol.name())};
           context_.set_location(symbol.name());
-          CheckInitialTarget(
+          CheckInitialDataPointerTarget(
               context_, *designator, *object->init(), DEREF(scope_));
         }
       }
@@ -1033,28 +1033,36 @@
         // C1519 - must be nonelemental external or module procedure,
         // or an unrestricted specific intrinsic function.
         const Symbol &ultimate{(*proc->init())->GetUltimate()};
+        bool checkTarget{true};
         if (ultimate.attrs().test(Attr::INTRINSIC)) {
-          if (const auto intrinsic{
-                  context_.intrinsics().IsSpecificIntrinsicFunction(
-                      ultimate.name().ToString())};
+          if (auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
+                  ultimate.name().ToString())};
               !intrinsic || intrinsic->isRestrictedSpecific) { // C1030
             context_.Say(
                 "Intrinsic procedure '%s' is not an unrestricted specific "
                 "intrinsic permitted for use as the initializer for procedure "
                 "pointer '%s'"_err_en_US,
                 ultimate.name(), symbol.name());
+            checkTarget = false;
           }
-        } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
-            ultimate.owner().kind() != Scope::Kind::Module) {
+        } else if ((!ultimate.attrs().test(Attr::EXTERNAL) &&
+                       ultimate.owner().kind() != Scope::Kind::Module) ||
+            IsDummy(ultimate) || IsPointer(ultimate)) {
           context_.Say("Procedure pointer '%s' initializer '%s' is neither "
                        "an external nor a module procedure"_err_en_US,
               symbol.name(), ultimate.name());
+          checkTarget = false;
         } else if (IsElementalProcedure(ultimate)) {
           context_.Say("Procedure pointer '%s' cannot be initialized with the "
-                       "elemental procedure '%s"_err_en_US,
+                       "elemental procedure '%s'"_err_en_US,
               symbol.name(), ultimate.name());
-        } else {
-          // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
+          checkTarget = false;
+        }
+        if (checkTarget) {
+          SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
+          SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
+          CheckPointerAssignment(context_, lhs, rhs,
+              GetProgramUnitOrBlockConstructContaining(symbol));
         }
       }
     }
@@ -1148,6 +1156,9 @@
 void CheckHelper::CheckProcEntity(
     const Symbol &symbol, const ProcEntityDetails &details) {
   CheckSymbolType(symbol);
+  const Symbol *interface {
+    details.procInterface() ? &details.procInterface()->GetUltimate() : nullptr
+  };
   if (details.isDummy()) {
     if (!symbol.attrs().test(Attr::POINTER) && // C843
         (symbol.attrs().test(Attr::INTENT_IN) ||
@@ -1160,20 +1171,19 @@
       messages_.Say(
           "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
     }
-    const Symbol *interface {
-      details.procInterface()
-    };
-    if (!symbol.attrs().test(Attr::INTRINSIC) &&
-        (IsElementalProcedure(symbol) ||
-            (interface && !interface->attrs().test(Attr::INTRINSIC) &&
-                IsElementalProcedure(*interface)))) {
+    if (interface && IsElementalProcedure(*interface)) {
       // There's no explicit constraint or "shall" that we can find in the
       // standard for this check, but it seems to be implied in multiple
       // sites, and ELEMENTAL non-intrinsic actual arguments *are*
       // explicitly forbidden.  But we allow "PROCEDURE(SIN)::dummy"
       // because it is explicitly legal to *pass* the specific intrinsic
       // function SIN as an actual argument.
-      messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
+      if (interface->attrs().test(Attr::INTRINSIC)) {
+        messages_.Say(
+            "A dummy procedure should not have an ELEMENTAL intrinsic as its interface"_port_en_US);
+      } else {
+        messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
+      }
     }
   } else if (symbol.attrs().test(Attr::INTENT_IN) ||
       symbol.attrs().test(Attr::INTENT_OUT) ||
@@ -1183,35 +1193,35 @@
   } else if (IsOptional(symbol)) {
     messages_.Say("OPTIONAL attribute may apply only to a dummy "
                   "argument"_err_en_US); // C849
-  } else if (symbol.owner().IsDerivedType()) {
-    if (!symbol.attrs().test(Attr::POINTER)) { // C756
-      const auto &name{symbol.name()};
-      messages_.Say(name,
-          "Procedure component '%s' must have POINTER attribute"_err_en_US,
-          name);
-    }
-    CheckPassArg(symbol, details.procInterface(), details);
-  }
-  if (IsPointer(symbol)) {
+  } else if (IsPointer(symbol)) {
     CheckPointerInitialization(symbol);
-    if (const Symbol * interface{details.procInterface()}) {
-      const Symbol &ultimate{interface->GetUltimate()};
-      if (ultimate.attrs().test(Attr::INTRINSIC)) {
-        if (const auto intrinsic{
-                context_.intrinsics().IsSpecificIntrinsicFunction(
-                    ultimate.name().ToString())};
-            !intrinsic || intrinsic->isRestrictedSpecific) { // C1515
+    if (interface) {
+      if (interface->attrs().test(Attr::INTRINSIC)) {
+        auto intrinsic{context_.intrinsics().IsSpecificIntrinsicFunction(
+            interface->name().ToString())};
+        if (!intrinsic || intrinsic->isRestrictedSpecific) { // C1515
           messages_.Say(
               "Intrinsic procedure '%s' is not an unrestricted specific "
               "intrinsic permitted for use as the definition of the interface "
               "to procedure pointer '%s'"_err_en_US,
-              ultimate.name(), symbol.name());
+              interface->name(), symbol.name());
+        } else if (IsElementalProcedure(*interface)) {
+          messages_.Say(
+              "Procedure pointer '%s' should not have an ELEMENTAL intrinsic as its interface"_port_en_US,
+              symbol.name()); // C1517
         }
       } else if (IsElementalProcedure(*interface)) {
         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
             symbol.name()); // C1517
       }
     }
+    if (symbol.owner().IsDerivedType()) {
+      CheckPassArg(symbol, interface, details);
+    }
+  } else if (symbol.owner().IsDerivedType()) {
+    const auto &name{symbol.name()};
+    messages_.Say(name,
+        "Procedure component '%s' must have POINTER attribute"_err_en_US, name);
   }
   CheckExternal(symbol);
 }
Index: flang/lib/Semantics/data-to-inits.cpp
===================================================================
--- flang/lib/Semantics/data-to-inits.cpp
+++ flang/lib/Semantics/data-to-inits.cpp
@@ -406,7 +406,7 @@
       exprAnalyzer_.Say(
           "Procedure '%s' may not be used to initialize '%s', which is not a procedure pointer"_err_en_US,
           expr->AsFortran(), DescribeElement());
-    } else if (CheckInitialTarget(
+    } else if (CheckInitialDataPointerTarget(
                    exprAnalyzer_.context(), designator, *expr, DEREF(scope_))) {
       GetImage().AddPointer(offsetSymbol.offset(), *expr);
       return true;
Index: flang/lib/Semantics/pointer-assignment.h
===================================================================
--- flang/lib/Semantics/pointer-assignment.h
+++ flang/lib/Semantics/pointer-assignment.h
@@ -27,16 +27,17 @@
     SemanticsContext &, const evaluate::Assignment &, const Scope &);
 bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs,
     const SomeExpr &rhs, const Scope &, bool isBoundsRemapping = false);
-bool CheckStructConstructorPointerComponent(
-    SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
 bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source,
     const std::string &description,
     const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs,
     const Scope &);
 
+bool CheckStructConstructorPointerComponent(
+    SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
+
 // Checks whether an expression is a valid static initializer for a
 // particular pointer designator.
-bool CheckInitialTarget(SemanticsContext &, const SomeExpr &pointer,
+bool CheckInitialDataPointerTarget(SemanticsContext &, const SomeExpr &pointer,
     const SomeExpr &init, const Scope &);
 
 } // namespace Fortran::semantics
Index: flang/lib/Semantics/pointer-assignment.cpp
===================================================================
--- flang/lib/Semantics/pointer-assignment.cpp
+++ flang/lib/Semantics/pointer-assignment.cpp
@@ -360,7 +360,8 @@
 }
 
 bool PointerAssignmentChecker::Check(const evaluate::ProcedureDesignator &d) {
-  if (const Symbol * symbol{d.GetSymbol()}) {
+  const Symbol *symbol{d.GetSymbol()};
+  if (symbol) {
     if (const auto *subp{
             symbol->GetUltimate().detailsIf<SubprogramDetails>()}) {
       if (subp->stmtFunction()) {
@@ -377,6 +378,10 @@
     }
   }
   if (auto chars{Procedure::Characterize(d, foldingContext_)}) {
+    // Disregard the elemental attribute of RHS intrinsics.
+    if (symbol && symbol->GetUltimate().attrs().test(Attr::INTRINSIC)) {
+      chars->attrs.reset(Procedure::Attr::Elemental);
+    }
     return Check(d.GetName(), false, &*chars, d.GetSpecificIntrinsic());
   } else {
     return Check(d.GetName(), false);
@@ -517,8 +522,8 @@
       .Check(rhs);
 }
 
-bool CheckInitialTarget(SemanticsContext &context, const SomeExpr &pointer,
-    const SomeExpr &init, const Scope &scope) {
+bool CheckInitialDataPointerTarget(SemanticsContext &context,
+    const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) {
   return evaluate::IsInitialDataTarget(
              init, &context.foldingContext().messages()) &&
       CheckPointerAssignment(context, pointer, init, scope);
Index: flang/test/Semantics/block-data01.f90
===================================================================
--- flang/test/Semantics/block-data01.f90
+++ flang/test/Semantics/block-data01.f90
@@ -7,6 +7,7 @@
   !ERROR: An initialized variable in BLOCK DATA must be in a COMMON block
   integer :: notInCommon = 1
   integer :: uninitialized ! ok
+  !PORTABILITY: Procedure pointer 'q' should not have an ELEMENTAL intrinsic as its interface
   !ERROR: 'q' may not appear in a BLOCK DATA subprogram
   procedure(sin), pointer :: q => cos
   !ERROR: 'p' may not be a procedure as it is in a COMMON block
Index: flang/test/Semantics/c_loc01.f90
===================================================================
--- flang/test/Semantics/c_loc01.f90
+++ flang/test/Semantics/c_loc01.f90
@@ -11,6 +11,7 @@
     type(c_ptr) cp
     type(c_funptr) cfp
     real notATarget
+    !PORTABILITY: Procedure pointer 'pptr' should not have an ELEMENTAL intrinsic as its interface
     procedure(sin), pointer :: pptr
     real, target :: arr(3)
     type(hasLen(1)), target :: clen
Index: flang/test/Semantics/call02.f90
===================================================================
--- flang/test/Semantics/call02.f90
+++ flang/test/Semantics/call02.f90
@@ -8,6 +8,7 @@
       real, intent(in), value :: x
     end function
     subroutine subr(dummy)
+      !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
       procedure(sin) :: dummy
     end subroutine
     subroutine badsubr(dummy)
@@ -16,9 +17,11 @@
       procedure(elem) :: dummy
     end subroutine
     subroutine optionalsubr(dummy)
+      !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
       procedure(sin), optional :: dummy
     end subroutine
     subroutine ptrsubr(dummy)
+      !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
       procedure(sin), pointer, intent(in) :: dummy
     end subroutine
   end interface
Index: flang/test/Semantics/call09.f90
===================================================================
--- flang/test/Semantics/call09.f90
+++ flang/test/Semantics/call09.f90
@@ -37,6 +37,7 @@
   end subroutine
 
   subroutine selemental1(p)
+    !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
     procedure(cos) :: p ! ok
   end subroutine
 
Index: flang/test/Semantics/io11.f90
===================================================================
--- flang/test/Semantics/io11.f90
+++ flang/test/Semantics/io11.f90
@@ -80,9 +80,10 @@
 contains
   !ERROR: Dummy argument 0 of 'formattedreadproc' must be a data object
   !ERROR: Cannot use an alternate return as the passed-object dummy argument
-  subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg) 
+  subroutine formattedReadProc(*, unit, iotype, vlist, iostat, iomsg)
     !ERROR: Dummy argument 'unit' must be a data object
     !ERROR: A dummy procedure without the POINTER attribute may not have an INTENT attribute
+    !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
     procedure(sin), intent(in) :: unit
     character(len=*), intent(in) :: iotype
     integer, intent(in) :: vlist(:)
Index: flang/test/Semantics/modfile49.f90
===================================================================
--- flang/test/Semantics/modfile49.f90
+++ flang/test/Semantics/modfile49.f90
@@ -4,7 +4,11 @@
 module m
   type :: t
   end type
-  procedure(sin) :: ext
+  abstract interface
+    subroutine iface
+    end
+  end interface
+  procedure(iface) :: ext
   interface
     subroutine subr(p1,p2)
       import ext, t
@@ -22,8 +26,11 @@
 !module m
 !type::t
 !end type
-!intrinsic::sin
-!procedure(sin)::ext
+!abstract interface
+!subroutine iface()
+!end
+!end interface
+!procedure(iface)::ext
 !interface
 !subroutine subr(p1,p2)
 !import::ext
Index: flang/test/Semantics/procinterface01.f90
===================================================================
--- flang/test/Semantics/procinterface01.f90
+++ flang/test/Semantics/procinterface01.f90
@@ -48,7 +48,7 @@
  type :: derived1
   !REF: /module1/abstract1
   !DEF: /module1/derived1/p1 NOPASS, POINTER (Function) ProcEntity REAL(4)
-  !DEF: /module1/nested1 PUBLIC (Function) Subprogram REAL(4)
+  !DEF: /module1/nested1 PUBLIC, PURE (Function) Subprogram REAL(4)
   procedure(abstract1), pointer, nopass :: p1 => nested1
   !REF: /module1/explicit1
   !DEF: /module1/derived1/p2 NOPASS, POINTER (Function) ProcEntity REAL(4)
@@ -81,7 +81,7 @@
 
  !REF: /module1/nested1
  !DEF: /module1/nested1/x INTENT(IN) ObjectEntity REAL(4)
- real function nested1(x)
+ pure real function nested1(x)
   !REF: /module1/nested1/x
   real, intent(in) :: x
   !DEF: /module1/nested1/nested1 ObjectEntity REAL(4)
Index: flang/test/Semantics/procinterface02.f90
===================================================================
--- flang/test/Semantics/procinterface02.f90
+++ flang/test/Semantics/procinterface02.f90
@@ -12,6 +12,7 @@
     end function
   end interface
   real :: A(:), B(:)
+  !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
   procedure(sqrt), pointer :: P
   !ERROR: Rank of dummy argument is 0, but actual argument has rank 1
   A = P(B)
Index: flang/test/Semantics/procinterface04.f90
===================================================================
--- /dev/null
+++ flang/test/Semantics/procinterface04.f90
@@ -0,0 +1,24 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+subroutine test(dp1, dp2)
+  intrinsic sin
+  interface
+    elemental real function elemental(x)
+      real, intent(in) :: x
+    end
+    pure real function nonelemental(x)
+      real, intent(in) :: x
+    end
+  end interface
+  !PORTABILITY: A dummy procedure should not have an ELEMENTAL intrinsic as its interface
+  procedure(sin) :: dp1
+  !ERROR: A dummy procedure may not be ELEMENTAL
+  procedure(elemental) :: dp2
+  !PORTABILITY: Procedure pointer 'pp1' should not have an ELEMENTAL intrinsic as its interface
+  procedure(sin), pointer :: pp1
+  !ERROR: Procedure pointer 'pp2' may not be ELEMENTAL
+  procedure(elemental), pointer :: pp2
+  procedure(elemental) :: pp3 ! ok, external
+  procedure(nonelemental), pointer :: pp4 => sin ! ok, special case
+  !ERROR: Procedure pointer 'pp5' cannot be initialized with the elemental procedure 'elemental'
+  procedure(nonelemental), pointer :: pp5 => elemental
+end
Index: flang/test/Semantics/reduce01.f90
===================================================================
--- flang/test/Semantics/reduce01.f90
+++ flang/test/Semantics/reduce01.f90
@@ -70,13 +70,13 @@
     b = reduce(a, f4)
     !ERROR: OPERATION= argument of REDUCE() must have the same type as ARRAY=
     b = reduce(a, f5)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
     b = reduce(a, f6)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
     b = reduce(a, f7)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
     b = reduce(a, f8)
-    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, or optional
+    !ERROR: Arguments of OPERATION= procedure of REDUCE() must be both scalar of the same type as ARRAY=, and neither allocatable, pointer, polymorphic, nor optional
     b = reduce(a, f9)
     !ERROR: If either argument of the OPERATION= procedure of REDUCE() has the ASYNCHRONOUS, VOLATILE, or TARGET attribute, both must have that attribute
     b = reduce(a, f10)
Index: flang/test/Semantics/resolve114.f90
===================================================================
--- flang/test/Semantics/resolve114.f90
+++ flang/test/Semantics/resolve114.f90
@@ -34,7 +34,9 @@
 subroutine s2a
   use m1
   use m2
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   procedure(sin), pointer :: p1 => sin
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   procedure(iabs), pointer :: p2 => iabs
   procedure(ext1), pointer :: p3 => ext1
   procedure(ext2), pointer :: p4 => ext2
@@ -44,7 +46,9 @@
   use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
   use m2, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
   use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   procedure(iface1), pointer :: p1 => x1
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   procedure(iface2), pointer :: p2 => x2
   procedure(iface3), pointer :: p3 => x3
   procedure(iface4), pointer :: p4 => x4
@@ -56,7 +60,9 @@
 end module
 subroutine s3
   use m3
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   procedure(sin), pointer :: p1 => sin
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   procedure(iabs), pointer :: p2 => iabs
   procedure(ext1), pointer :: p3 => ext1
   procedure(ext2), pointer :: p4 => ext2
@@ -69,7 +75,9 @@
 subroutine s4
   use m4
   use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   procedure(iface1), pointer :: p1 => x1
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   procedure(iface2), pointer :: p2 => x2
   procedure(iface3), pointer :: p3 => x3
   procedure(iface4), pointer :: p4 => x4
@@ -79,8 +87,10 @@
   use m1, only: x1 => sin, x2 => iabs, x3 => ext1, x4 => ext2
   use m2, only: x1 => tan, x2 => idim, x3 => ext2, x4 => ext1
   use m1, only: iface1 => sin, iface2 => iabs, iface3 => ext1, iface4 => ext2
+  !PORTABILITY: Procedure pointer 'p1' should not have an ELEMENTAL intrinsic as its interface
   !ERROR: Reference to 'x1' is ambiguous
   procedure(iface1), pointer :: p1 => x1
+  !PORTABILITY: Procedure pointer 'p2' should not have an ELEMENTAL intrinsic as its interface
   !ERROR: Reference to 'x2' is ambiguous
   procedure(iface2), pointer :: p2 => x2
   !ERROR: Reference to 'x3' is ambiguous
Index: flang/test/Semantics/resolve46.f90
===================================================================
--- flang/test/Semantics/resolve46.f90
+++ flang/test/Semantics/resolve46.f90
@@ -20,6 +20,7 @@
      end function chrcmp
   end interface
 
+  !PORTABILITY: Procedure pointer 'p' should not have an ELEMENTAL intrinsic as its interface
   procedure(sin), pointer :: p => cos
   !ERROR: Intrinsic procedure 'amin0' is not an unrestricted specific intrinsic permitted for use as the definition of the interface to procedure pointer 'q'
   procedure(amin0), pointer :: q
@@ -28,6 +29,7 @@
   !ERROR: Intrinsic procedure 'llt' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 's'
   procedure(chrcmp), pointer :: s => llt
   !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 't'
+  !PORTABILITY: Procedure pointer 't' should not have an ELEMENTAL intrinsic as its interface
   procedure(cos), pointer :: t => bessel_j0
   procedure(chrcmp), pointer :: u
   p => alog ! valid use of an unrestricted specific intrinsic
Index: flang/test/Semantics/resolve59.f90
===================================================================
--- flang/test/Semantics/resolve59.f90
+++ flang/test/Semantics/resolve59.f90
@@ -114,6 +114,7 @@
   end function
   function f5(x) result(r)
     real :: x
+    !PORTABILITY: Procedure pointer 'r' should not have an ELEMENTAL intrinsic as its interface
     procedure(acos), pointer :: r
     r => acos
     !ERROR: Actual argument for 'x=' may not be a procedure