SET_XERBLA - override the error-handler without linker stuff

.gitignore

@@ -15,6 +15,9 @@ make.inc
 BLAS/TESTING/*.out
 BLAS/TESTING/x*
 
+# Mod files from compilation in BLAS/SRC
+BLAS/SRC/blas_xerbla.mod
+
 # CBLAS
 CBLAS/include/cblas_mangling.h
 
@@ -52,3 +55,4 @@ output_err
 # Mod files from compilation in SRC
 SRC/la_constants.mod
 SRC/la_xisnan.mod
+SRC/lapack_xerbla.mod

BLAS/SRC/CMakeLists.txt

@@ -29,6 +29,8 @@
 #  Level 1 BLAS
 #---------------------------------------------------------
 
+set(XERBLAMOD xerbla_blas.f90)
+
 set(LAPACK_INSTALL_EXPORT_NAME ${BLASLIB}-targets)
 
 set(SBLAS1
@@ -60,7 +62,7 @@ set(ZB1AUX
 #---------------------------------------------------------------------
 #  Auxiliary routines needed by both the Level 2 and Level 3 BLAS
 #---------------------------------------------------------------------
-set(ALLBLAS lsame.f xerbla.f xerbla_array.f)
+set(ALLBLAS lsame.f xerbla.f xerbla_array.f ${XERBLAMOD})
 
 #---------------------------------------------------------
 #  Level 2 BLAS
@@ -117,8 +119,12 @@ if(BUILD_COMPLEX16)
 endif()
 list(REMOVE_DUPLICATES SOURCES)
 
+add_library(blas_mod_files OBJECT ${XERBLAMOD})
+lapack_add_coverage(blas_mod_files)
+
 if(BUILD_DEFAULT_API)
   add_library(${BLASLIB}_obj OBJECT ${SOURCES})
+  target_link_libraries(${BLASLIB}_obj PUBLIC blas_mod_files)
   lapack_add_coverage(${BLASLIB}_obj)
 endif()
 
@@ -127,6 +133,7 @@ if(BUILD_INDEX64_EXT_API)
   generate_64bit_suffixed_sources(${BLASLIB} SOURCES SOURCES_64)
 
   add_library(${BLASLIB}_64_obj OBJECT ${SOURCES_64})
+  target_link_libraries(${BLASLIB}_64_obj PUBLIC blas_mod_files)
   target_compile_options(${BLASLIB}_64_obj PRIVATE ${FOPT_ILP64})
 endif()
 

BLAS/SRC/Makefile

@@ -65,6 +65,10 @@ include $(TOPSRCDIR)/make.inc
 .PHONY: all
 all: $(BLASLIB)
 
+xerbla.o: blas_xerbla.mod
+blas_xerbla.mod: xerbla_blas.o
+	@true
+
 #---------------------------------------------------------
 #  Comment out the next 6 definitions if you already have
 #  the Level 1 BLAS.
@@ -176,6 +180,6 @@ FRC:
 .PHONY: clean cleanobj cleanlib
 clean: cleanobj cleanlib
 cleanobj:
-	rm -f *.o
+	rm -f *.o *.mod
 cleanlib:
 	#rm -f $(BLASLIB)  # May point to a system lib, e.g. -lblas

BLAS/SRC/xerbla.f

@@ -25,6 +25,10 @@
 *> It is called by an LAPACK routine if an input parameter has an
 *> invalid value.  A message is printed and execution stops.
 *>
+*> Users can replace the BLAS XERBLA by calling SET_BLAS_XERBLA
+*> with a replacement handler, or LAPACK's SET_XERBLA. See separate
+*> documentation.
+*>
 *> Installers may consider modifying the STOP statement in order to
 *> call system-specific exception-handling facilities.
 *> \endverbatim
@@ -57,6 +61,7 @@
 *
 *  =====================================================================
       SUBROUTINE XERBLA( SRNAME, INFO )
+      USE BLAS_XERBLA
       IMPLICIT NONE
 *
 *  -- Reference BLAS level1 routine --
@@ -72,9 +77,14 @@ SUBROUTINE XERBLA( SRNAME, INFO )
 *
 *     .. Intrinsic Functions ..
       INTRINSIC          LEN_TRIM
+      EXTERNAL XERBLA_BLAS
 *     ..
 *     .. Executable Statements ..
 *
+      IF (ASSOCIATED(ACTIVE_CALLBACK)) THEN
+        CALL XERBLA_BLAS(SRNAME, INFO)
+        RETURN
+      END IF
       WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
 *
       STOP

BLAS/SRC/xerbla_blas.f90

@@ -0,0 +1,102 @@
+!> \brief \b SET_BLAS_XERBLA
+!
+!  =========== DOCUMENTATION ===========
+!
+! Online html documentation available at
+!            http://www.netlib.org/lapack/explore-html/
+!
+!  Definition:
+!  ===========
+!
+!       SUBROUTINE SET_BLAS_XERBLA(CB)
+!       PROCEDURE(XERBLA_INTERFACE) :: CB
+!       ABSTRACT INTERFACE
+!         SUBROUTINE XERBLA_INTERFACE(SRNAME, INFO)
+!           CHARACTER*(*), INTENT(IN) :: SRNAME
+!           INTEGER, INTENT(IN) :: INFO
+!         END SUBROUTINE
+!       END INTERFACE
+!       ..
+!
+!
+!> \par Purpose:
+!  =============
+!>
+!> \verbatim
+!>
+!> SET_BLAS_XERBLA overrides the BLAS XERBLA with a replacement subroutine.
+!> This can then be negated by calling SET_BLAS_XERBLA with NULL().
+!> The current handler value can be retrieved by calling GET_BLAS_XERBLA:
+!>
+!>   PROGRAM HELLO
+!>     PROCEDURE(XERBLA_INTERFACE), POINTER :: ALREADY_CB
+!>     INTERFACE
+!>       SUBROUTINE XERBLA_INTERFACE(SRNAME, INFO)
+!>         CHARACTER*(*), INTENT(IN) :: SRNAME
+!>         INTEGER, INTENT(IN) :: INFO
+!>       END SUBROUTINE
+!>       FUNCTION GET_BLAS_XERBLA() RESULT(CB_RET)
+!>         IMPLICIT NONE
+!>         PROCEDURE(XERBLA_INTERFACE), POINTER :: CB_RET
+!>       END FUNCTION
+!>     END INTERFACE
+!>     ALREADY_CB => GET_BLAS_XERBLA()
+!>   END PROGRAM HELLO
+!> \endverbatim
+!
+!  Arguments:
+!  ==========
+!
+!> \param[in] CB
+!> \verbatim
+!>          CB is a pointer to a PROCEDURE that takes the same
+!>          arguments as XERBLA.
+!> \endverbatim
+!
+!  Authors:
+!  ========
+!
+!> \author Ed J
+!
+!> \date September 2026
+!
+!> \ingroup xerbla
+!
+!  =====================================================================
+module blas_xerbla
+  private
+  public :: active_callback, xerbla_interface
+  intrinsic          null
+  procedure(xerbla_interface), pointer :: active_callback => null()
+  abstract interface
+    subroutine xerbla_interface(srname, info)
+      character*(*), intent(in) :: srname
+      integer, intent(in) :: info
+    end subroutine
+  end interface
+end module blas_xerbla
+
+subroutine xerbla_blas(srname, info)
+  use blas_xerbla
+  character*(*)      srname
+  integer            info
+  if (.not. associated(active_callback)) then
+    print *, 'Error: BLAS XERBLA called but no callback registered'
+    stop
+  end if
+  call active_callback(srname, info)
+end
+
+subroutine set_blas_xerbla(cb)
+  use blas_xerbla
+  implicit none
+  procedure(xerbla_interface) :: cb
+  active_callback => cb
+end
+
+function get_blas_xerbla() result(cb_ret)
+  use blas_xerbla
+  implicit none
+  procedure(xerbla_interface), pointer :: cb_ret
+  cb_ret => active_callback
+end

BLAS/TESTING/cblat2.f

@@ -149,7 +149,7 @@ PROGRAM CBLAT2
       EXTERNAL           SDIFF, LCE
 *     .. External Subroutines ..
       EXTERNAL           CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6,
-     $                   CCHKE, CMVCH
+     $                   CCHKE, CMVCH, SET_BLAS_XERBLA, XER_REPLACE
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, MIN
 *     .. Scalars in Common ..
@@ -165,8 +165,21 @@ PROGRAM CBLAT2
      $                   'CTRSV ', 'CTBSV ', 'CTPSV ', 'CGERC ',
      $                   'CGERU ', 'CHER  ', 'CHPR  ', 'CHER2 ',
      $                   'CHPR2 '/
+      PROCEDURE(XERBLA_INTERFACE), POINTER :: ALREADY_CB
+      INTERFACE
+        SUBROUTINE XERBLA_INTERFACE(SRNAME, INFO)
+          CHARACTER*(*), INTENT(IN) :: SRNAME
+          INTEGER, INTENT(IN) :: INFO
+        END SUBROUTINE
+        FUNCTION GET_BLAS_XERBLA() RESULT(CB_RET)
+          IMPLICIT NONE
+          PROCEDURE(XERBLA_INTERFACE), POINTER :: CB_RET
+        END FUNCTION
+      END INTERFACE
 *     .. Executable Statements ..
       CALL CPU_TIME( S1 )
+      ALREADY_CB => GET_BLAS_XERBLA()
+      CALL SET_BLAS_XERBLA(XER_REPLACE)
 *
 *     Read name and unit number for summary output file and open file.
 *
@@ -3403,7 +3416,7 @@ SUBROUTINE CREGR1( TRANS, M, N, LY, KL, KU, ALPHA, A, LDA, X,
   10  CONTINUE
       RETURN
       END
-      SUBROUTINE XERBLA( SRNAME, INFO )
+      SUBROUTINE XER_REPLACE( SRNAME, INFO )
       IMPLICIT NONE
 *
 *  This is a special version of XERBLA to be used only as part of

BLAS/TESTING/cblat3.f

@@ -130,7 +130,7 @@ PROGRAM CBLAT3
       EXTERNAL           SDIFF, LCE
 *     .. External Subroutines ..
       EXTERNAL           CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHKE, CMMCH
-      EXTERNAL           CCHK6
+      EXTERNAL           CCHK6, SET_BLAS_XERBLA, XER_REPLACE
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
 *     .. Scalars in Common ..
@@ -146,6 +146,7 @@ PROGRAM CBLAT3
      $                   'CSYR2K', 'CGEMMTR'/
 *     .. Executable Statements ..
       CALL CPU_TIME( S1 )
+      CALL SET_BLAS_XERBLA(XER_REPLACE)
 *
 *     Read name and unit number for summary output file and open file.
 *
@@ -3726,7 +3727,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
 *     End of CHKXER
 *
       END
-      SUBROUTINE XERBLA( SRNAME, INFO )
+      SUBROUTINE XER_REPLACE( SRNAME, INFO )
 *
 *  This is a special version of XERBLA to be used only as part of
 *  the test program for testing error exits from the Level 3 BLAS

BLAS/TESTING/dblat2.f

@@ -147,7 +147,7 @@ PROGRAM DBLAT2
       EXTERNAL           DDIFF, LDE
 *     .. External Subroutines ..
       EXTERNAL           DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6,
-     $                   DCHKE, DMVCH
+     $                   DCHKE, DMVCH, SET_BLAS_XERBLA, XER_REPLACE
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, MIN
 *     .. Scalars in Common ..
@@ -169,6 +169,7 @@ PROGRAM DBLAT2
      $                   'DSKEWSYMV ', 'DSKEWSYR2 '/
 *     .. Executable Statements ..
       CALL CPU_TIME( S1 )
+      CALL SET_BLAS_XERBLA(XER_REPLACE)
 *
 *     Read name and unit number for summary output file and open file.
 *
@@ -3385,7 +3386,7 @@ SUBROUTINE DREGR1( TRANS, M, N, LY, KL, KU, ALPHA, A, LDA, X,
   10  CONTINUE
       RETURN
       END
-      SUBROUTINE XERBLA( SRNAME, INFO )
+      SUBROUTINE XER_REPLACE( SRNAME, INFO )
       IMPLICIT NONE
 *
 *  This is a special version of XERBLA to be used only as part of

BLAS/TESTING/dblat3.f

@@ -126,7 +126,7 @@ PROGRAM DBLAT3
       EXTERNAL           DDIFF, LDE
 *     .. External Subroutines ..
       EXTERNAL           DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHKE, DMMCH
-      EXTERNAL           DCHK6
+      EXTERNAL           DCHK6, SET_BLAS_XERBLA, XER_REPLACE
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
 *     .. Scalars in Common ..
@@ -144,6 +144,7 @@ PROGRAM DBLAT3
      $                   'DSKEWSYMM  ', 'DSKEWSYR2K '/
 *     .. Executable Statements ..
       CALL CPU_TIME( S1 )
+      CALL SET_BLAS_XERBLA(XER_REPLACE)
 *
 *     Read name and unit number for summary output file and open file.
 *
@@ -3204,7 +3205,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
 *     End of CHKXER
 *
       END
-      SUBROUTINE XERBLA( SRNAME, INFO )
+      SUBROUTINE XER_REPLACE( SRNAME, INFO )
       IMPLICIT NONE
 *
 *  This is a special version of XERBLA to be used only as part of

BLAS/TESTING/sblat2.f

@@ -147,7 +147,7 @@ PROGRAM SBLAT2
       EXTERNAL           SDIFF, LSE
 *     .. External Subroutines ..
       EXTERNAL           SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6,
-     $                   SCHKE, SMVCH
+     $                   SCHKE, SMVCH, SET_BLAS_XERBLA, XER_REPLACE
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, MIN
 *     .. Scalars in Common ..
@@ -169,6 +169,7 @@ PROGRAM SBLAT2
      $                   'SSKEWSYMV ', 'SSKEWSYR2 '/
 *     .. Executable Statements ..
       CALL CPU_TIME( S1 )
+      CALL SET_BLAS_XERBLA(XER_REPLACE)
 *
 *     Read name and unit number for summary output file and open file.
 *
@@ -3385,7 +3386,7 @@ SUBROUTINE SREGR1( TRANS, M, N, LY, KL, KU, ALPHA, A, LDA, X,
   10  CONTINUE
       RETURN
       END
-      SUBROUTINE XERBLA( SRNAME, INFO )
+      SUBROUTINE XER_REPLACE( SRNAME, INFO )
       IMPLICIT NONE
 *
 *  This is a special version of XERBLA to be used only as part of

BLAS/TESTING/sblat3.f

@@ -126,7 +126,7 @@ PROGRAM SBLAT3
       EXTERNAL           SDIFF, LSE
 *     .. External Subroutines ..
       EXTERNAL           SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHKE, SMMCH
-      EXTERNAL           SCHK6
+      EXTERNAL           SCHK6, SET_BLAS_XERBLA, XER_REPLACE
 *     .. Intrinsic Functions ..
       INTRINSIC          MAX, MIN
 *     .. Scalars in Common ..
@@ -144,6 +144,7 @@ PROGRAM SBLAT3
      $                   'SSKEWSYMM  ', 'SSKEWSYR2K '/
 *     .. Executable Statements ..
       CALL CPU_TIME( S1 )
+      CALL SET_BLAS_XERBLA(XER_REPLACE)
 *
 *     Read name and unit number for summary output file and open file.
 *
@@ -3205,7 +3206,7 @@ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
 *     End of CHKXER
 *
       END
-      SUBROUTINE XERBLA( SRNAME, INFO )
+      SUBROUTINE XER_REPLACE( SRNAME, INFO )
       IMPLICIT NONE
 *
 *  This is a special version of XERBLA to be used only as part of