diff --git a/flang/lib/Semantics/check-do-forall.cpp b/flang/lib/Semantics/check-do-forall.cpp
--- a/flang/lib/Semantics/check-do-forall.cpp
+++ b/flang/lib/Semantics/check-do-forall.cpp
@@ -219,6 +219,16 @@
         SayDeallocateWithImpureFinal(*entity, reason);
       }
     }
+    if (const auto *assignment{GetAssignment(stmt)}) {
+      if (const auto *call{
+              std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {
+        if (auto bad{FindImpureCall(context_.foldingContext(), *call)}) {
+          context_.Say(currentStatementSourcePosition_,
+              "The defined assignment subroutine '%s' is not pure"_err_en_US,
+              *bad);
+        }
+      }
+    }
   }
 
   // Deallocation from a DEALLOCATE statement
@@ -431,10 +441,10 @@
   }
 
   void Check(const parser::ForallAssignmentStmt &stmt) {
-    const evaluate::Assignment *assignment{common::visit(
-        common::visitors{[&](const auto &x) { return GetAssignment(x); }},
-        stmt.u)};
-    if (assignment) {
+    if (const evaluate::Assignment *
+        assignment{common::visit(
+            common::visitors{[&](const auto &x) { return GetAssignment(x); }},
+            stmt.u)}) {
       CheckForallIndexesUsed(*assignment);
       CheckForImpureCall(assignment->lhs);
       CheckForImpureCall(assignment->rhs);
diff --git a/flang/test/Semantics/doconcurrent01.f90 b/flang/test/Semantics/doconcurrent01.f90
--- a/flang/test/Semantics/doconcurrent01.f90
+++ b/flang/test/Semantics/doconcurrent01.f90
@@ -237,3 +237,34 @@
     end function pureFunc
 
 end subroutine s7
+
+module m8
+  type t
+   contains
+    procedure tbpAssign
+    generic :: assignment(=) => tbpAssign
+  end type
+  interface assignment(=)
+    module procedure nonTbpAssign
+  end interface
+ contains
+  impure elemental subroutine tbpAssign(to, from)
+    class(t), intent(out) :: to
+    class(t), intent(in) :: from
+    print *, 'impure due to I/O'
+  end
+  impure elemental subroutine nonTbpAssign(to, from)
+    type(t), intent(out) :: to
+    integer, intent(in) :: from
+    print *, 'impure due to I/O'
+  end
+  subroutine test
+    type(t) x, y
+    do concurrent (j=1:1)
+      !ERROR: The defined assignment subroutine 'tbpassign' is not pure
+      x = y
+      !ERROR: The defined assignment subroutine 'nontbpassign' is not pure
+      x = 666
+    end do
+  end
+end