diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
index 239eab1d4e418..076f7bda6171c 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
@@ -37,5 +37,8 @@ void genNullifyDerivedType(fir::FirOpBuilder &builder, mlir::Location loc,
                            mlir::Value box, fir::RecordType derivedType,
                            unsigned rank = 0);
 
+mlir::Value genSameTypeAs(fir::FirOpBuilder &builder, mlir::Location loc,
+                          mlir::Value a, mlir::Value b);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H
diff --git a/flang/include/flang/Runtime/derived-api.h b/flang/include/flang/Runtime/derived-api.h
index 5d08694dd58c7..1433f91b9f025 100644
--- a/flang/include/flang/Runtime/derived-api.h
+++ b/flang/include/flang/Runtime/derived-api.h
@@ -46,6 +46,9 @@ void RTNAME(Assign)(const Descriptor &, const Descriptor &,
 // construct.
 bool RTNAME(ClassIs)(const Descriptor &, const typeInfo::DerivedType &);
 
+// Perform the test of the SAME_TYPE_AS intrinsic.
+bool RTNAME(SameTypeAs)(const Descriptor &, const Descriptor &);
+
 } // extern "C"
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_DERIVED_API_H_
diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp
index 1ee096f197c19..f8c601c829d41 100644
--- a/flang/lib/Lower/IntrinsicCall.cpp
+++ b/flang/lib/Lower/IntrinsicCall.cpp
@@ -25,6 +25,7 @@
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Builder/Runtime/Character.h"
 #include "flang/Optimizer/Builder/Runtime/Command.h"
+#include "flang/Optimizer/Builder/Runtime/Derived.h"
 #include "flang/Optimizer/Builder/Runtime/Inquiry.h"
 #include "flang/Optimizer/Builder/Runtime/Numeric.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
@@ -564,6 +565,8 @@ struct IntrinsicLibrary {
   fir::ExtendedValue genReshape(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genRRSpacing(mlir::Type resultType,
                            llvm::ArrayRef<mlir::Value> args);
+  fir::ExtendedValue genSameTypeAs(mlir::Type,
+                                   llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genScale(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genScan(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genSelectedIntKind(mlir::Type, llvm::ArrayRef<mlir::Value>);
@@ -1013,6 +1016,10 @@ static constexpr IntrinsicHandler handlers[]{
        {"order", asBox, handleDynamicOptional}}},
      /*isElemental=*/false},
     {"rrspacing", &I::genRRSpacing},
+    {"same_type_as",
+     &I::genSameTypeAs,
+     {{{"a", asBox}, {"b", asBox}}},
+     /*isElemental=*/false},
     {"scale",
      &I::genScale,
      {{{"x", asValue}, {"i", asValue}}},
@@ -4491,6 +4498,18 @@ mlir::Value IntrinsicLibrary::genRRSpacing(mlir::Type resultType,
       fir::runtime::genRRSpacing(builder, loc, fir::getBase(args[0])));
 }
 
+// SAME_TYPE_AS
+fir::ExtendedValue
+IntrinsicLibrary::genSameTypeAs(mlir::Type resultType,
+                                llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 2);
+
+  return builder.createConvert(
+      loc, resultType,
+      fir::runtime::genSameTypeAs(builder, loc, fir::getBase(args[0]),
+                                  fir::getBase(args[1])));
+}
+
 // SCALE
 mlir::Value IntrinsicLibrary::genScale(mlir::Type resultType,
                                        llvm::ArrayRef<mlir::Value> args) {
diff --git a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
index 8700c9ef1254b..b2840360ec662 100644
--- a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
+++ b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
@@ -62,3 +62,13 @@ void fir::runtime::genNullifyDerivedType(fir::FirOpBuilder &builder,
   args.push_back(c0);
   builder.create<fir::CallOp>(loc, callee, args);
 }
+
+mlir::Value fir::runtime::genSameTypeAs(fir::FirOpBuilder &builder,
+                                        mlir::Location loc, mlir::Value a,
+                                        mlir::Value b) {
+  mlir::func::FuncOp sameTypeAsFunc =
+      fir::runtime::getRuntimeFunc<mkRTKey(SameTypeAs)>(loc, builder);
+  auto fTy = sameTypeAsFunc.getFunctionType();
+  auto args = fir::runtime::createArguments(builder, loc, fTy, a, b);
+  return builder.create<fir::CallOp>(loc, sameTypeAsFunc, args).getResult(0);
+}
diff --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp
index 5817296b0b1a1..722ae11d6f461 100644
--- a/flang/runtime/derived-api.cpp
+++ b/flang/runtime/derived-api.cpp
@@ -58,6 +58,44 @@ bool RTNAME(ClassIs)(
   return false;
 }
 
+static bool CompareDerivedTypeNames(const Descriptor &a, const Descriptor &b) {
+  if (a.raw().version == CFI_VERSION &&
+      a.type() == TypeCode{TypeCategory::Character, 1} &&
+      a.ElementBytes() > 0 && a.rank() == 0 && a.OffsetElement() != nullptr &&
+      a.raw().version == CFI_VERSION &&
+      b.type() == TypeCode{TypeCategory::Character, 1} &&
+      b.ElementBytes() > 0 && b.rank() == 0 && b.OffsetElement() != nullptr &&
+      a.ElementBytes() == b.ElementBytes() &&
+      memcmp(a.OffsetElement(), b.OffsetElement(), a.ElementBytes()) == 0) {
+    return true;
+  }
+  return false;
+}
+
+static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) {
+  if (const DescriptorAddendum * addendum{desc.Addendum()}) {
+    if (const auto *derived{addendum->derivedType()}) {
+      return derived;
+    }
+  }
+  return nullptr;
+}
+
+bool RTNAME(SameTypeAs)(const Descriptor &a, const Descriptor &b) {
+  const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
+  const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)};
+  if (derivedTypeA == nullptr || derivedTypeB == nullptr) {
+    return false;
+  }
+  // Exact match of derived type.
+  if (derivedTypeA == derivedTypeB) {
+    return true;
+  }
+  // Otherwise compare with the name. Note 16.29 kind type parameters are not
+  // considered in the test.
+  return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name());
+}
+
 // TODO: Assign()
 
 } // extern "C"
diff --git a/flang/test/Lower/Intrinsics/same_type_as.f90 b/flang/test/Lower/Intrinsics/same_type_as.f90
new file mode 100644
index 0000000000000..d8d524a86bda7
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/same_type_as.f90
@@ -0,0 +1,47 @@
+! RUN: bbc -emit-fir -polymorphic-type %s -o - | FileCheck %s
+
+module same_type_as_mod
+
+  type p1
+    integer :: a
+  end type
+
+  type, extends(p1) :: p2
+    integer :: b
+  end type
+
+  type k1(a)
+    integer, kind :: a
+  end type
+
+contains
+  subroutine is_same_type(a, b)
+    class(*) :: a
+    class(*) :: b
+
+    if (same_type_as(a, b)) then
+      print*, 'same_type_as ok'
+    else
+      print*, 'same_type_as failed'
+    end if
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMsame_type_as_modPis_same_type(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<none> {fir.bindc_name = "a"}, %[[ARG1:.*]]: !fir.class<none> {fir.bindc_name = "b"}) {
+! CHECK: %[[BOX0:.*]] = fir.convert %[[ARG0]] : (!fir.class<none>) -> !fir.box<none>
+! CHECK: %[[BOX1:.*]] = fir.convert %[[ARG1]] : (!fir.class<none>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranASameTypeAs(%[[BOX0]], %[[BOX1]]) {{.*}} : (!fir.box<none>, !fir.box<none>) -> i1
+
+end module
+
+program test
+  use same_type_as_mod
+  type(p1) :: p, r
+  type(p2) :: q
+  type(k1(10)) :: k10
+  type(k1(20)) :: k20
+
+  call is_same_type(p, q)
+  call is_same_type(p, r)
+  call is_same_type(k10, k20)
+end