Add IBLAVER to BLAS

.github/workflows/compilers.yml

@@ -106,6 +106,12 @@ jobs:
           os: macos-26
           CFLAGS: "-Wall -pedantic"
           FFLAGS: "-Wall -pedantic -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label"
+        - FC: gfortran-14
+          name: macos / gfortran / 2-level namespace
+          CC: gcc-14
+          os: macos-26
+          CFLAGS: "-Wall -pedantic"
+          FFLAGS: "-Wall -pedantic -Wno-unused-dummy-argument -Wno-unused-variable -Wno-unused-label"
         - FC: flang
           CC: clang
           os: ubuntu-26.04

.gitignore

@@ -15,6 +15,9 @@ make.inc
 BLAS/TESTING/*.out
 BLAS/TESTING/x*
 
+# Mod files from compilation in BLAS/SRC
+BLAS/SRC/xerbla_blas.mod
+
 # CBLAS
 CBLAS/include/cblas_mangling.h
 CBLAS/include/cblas_f77.h
@@ -57,3 +60,4 @@ output_err
 # Mod files from compilation in SRC
 SRC/la_constants.mod
 SRC/la_xisnan.mod
+SRC/xerbla_lapack.mod

BLAS/SRC/CMakeLists.txt

@@ -60,7 +60,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 xerbla_blas.f90 iblaver.f)
 
 #---------------------------------------------------------
 #  Level 2 BLAS

BLAS/SRC/Makefile

@@ -65,6 +65,9 @@ include $(TOPSRCDIR)/make.inc
 .PHONY: all
 all: $(BLASLIB)
 
+# force ordering of .mod building
+xerbla.o: xerbla_blas.o
+
 #---------------------------------------------------------
 #  Comment out the next 6 definitions if you already have
 #  the Level 1 BLAS.
@@ -96,7 +99,7 @@ $(ZB1AUX): $(FRC)
 #  Level 2 and Level 3 BLAS.  Comment it out only if you already have
 #  both the Level 2 and 3 BLAS.
 #---------------------------------------------------------------------
-ALLBLAS = lsame.o xerbla.o xerbla_array.o
+ALLBLAS = lsame.o xerbla.o xerbla_array.o xerbla_blas.o iblaver.o
 $(ALLBLAS): $(FRC)
 
 #---------------------------------------------------------
@@ -176,6 +179,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/iblaver.f

@@ -0,0 +1,67 @@
+*> \brief \b IBLAVER returns the BLAS version.
+**
+*  =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+*            http://www.netlib.org/lapack/explore-html/
+*
+*  Definition:
+*  ===========
+*
+*     SUBROUTINE IBLAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+*
+*     INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
+*
+*
+*> \par Purpose:
+*  =============
+*>
+*> \verbatim
+*>
+*>  This subroutine returns the BLAS version.
+*> \endverbatim
+*
+*  Arguments:
+*  ==========
+*
+*>  \param[out] VERS_MAJOR
+*>      VERS_MAJOR is INTEGER
+*>      return the BLAS major version
+*>
+*>  \param[out] VERS_MINOR
+*>      VERS_MINOR is INTEGER
+*>      return the BLAS minor version from the major version
+*>
+*>  \param[out] VERS_PATCH
+*>      VERS_PATCH is INTEGER
+*>      return the BLAS patch version from the minor version
+*
+*  Authors:
+*  ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \ingroup iblaver
+*
+*  =====================================================================
+      SUBROUTINE IBLAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+      IMPLICIT NONE
+*
+*  -- Reference BLAS auxiliary routine --
+*  -- Reference BLAS is a software package provided by Univ. of Tennessee,--
+*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+*
+*  =====================================================================
+*
+      INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
+*  =====================================================================
+      VERS_MAJOR = 3
+      VERS_MINOR = 12
+      VERS_PATCH = 1
+*  =====================================================================
+*
+      RETURN
+      END

BLAS/SRC/xerbla.f

@@ -25,6 +25,9 @@
 *> 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. See separate documentation.
+*>
 *> Installers may consider modifying the STOP statement in order to
 *> call system-specific exception-handling facilities.
 *> \endverbatim
@@ -57,6 +60,7 @@
 *
 *  =====================================================================
       SUBROUTINE XERBLA( SRNAME, INFO )
+      USE XERBLA_BLAS
       IMPLICIT NONE
 *
 *  -- Reference BLAS level1 routine --
@@ -72,9 +76,14 @@ SUBROUTINE XERBLA( SRNAME, INFO )
 *
 *     .. Intrinsic Functions ..
       INTRINSIC          LEN_TRIM
+      EXTERNAL XERBLA_BLAS_SUB
 *     ..
 *     .. Executable Statements ..
 *
+      IF (ASSOCIATED(ACTIVE_CALLBACK)) THEN
+        CALL XERBLA_BLAS_SUB(SRNAME, INFO)
+        RETURN
+      END IF
       WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
 *
       STOP

BLAS/SRC/xerbla_blas.f90

@@ -0,0 +1,107 @@
+!> \brief \b SET_BLAS_XERBLA
+!
+!  =========== DOCUMENTATION ===========
+!
+! Online html documentation available at
+!            http://www.netlib.org/lapack/explore-html/
+!
+!  Definition:
+!  ===========
+!
+!       SUBROUTINE SET_BLAS_XERBLA(CB)
+!       ABSTRACT INTERFACE
+!         SUBROUTINE XERBLA_INTERFACE(SRNAME, INFO)
+!           CHARACTER*(*), INTENT(IN) :: SRNAME
+!           INTEGER, INTENT(IN) :: INFO
+!         END SUBROUTINE
+!       END INTERFACE
+!       PROCEDURE(XERBLA_INTERFACE) :: CB
+!       ..
+!
+!
+!> \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
+!>     INTERFACE
+!>       SUBROUTINE XERBLA_INTERFACE(SRNAME, INFO)
+!>         CHARACTER*(*), INTENT(IN) :: SRNAME
+!>         INTEGER, INTENT(IN) :: INFO
+!>       END SUBROUTINE
+!>       SUBROUTINE GET_BLAS_XERBLA(CB)
+!>         IMPORT :: XERBLA_INTERFACE
+!>         IMPLICIT NONE
+!>         PROCEDURE(XERBLA_INTERFACE), POINTER, INTENT(OUT) :: CB
+!>       END SUBROUTINE
+!>     END INTERFACE
+!>     PROCEDURE(XERBLA_INTERFACE), POINTER :: ALREADY_CB
+!>     CALL GET_BLAS_XERBLA(ALREADY_CB)
+!>   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 xerbla_blas
+  private
+  public :: active_callback, xerbla_interface
+  intrinsic          null
+  abstract interface
+    subroutine xerbla_interface(srname, info)
+      character*(*), intent(in) :: srname
+      integer, intent(in) :: info
+    end subroutine
+  end interface
+  procedure(xerbla_interface), pointer :: active_callback => null()
+end module xerbla_blas
+
+subroutine xerbla_blas_sub(srname, info)
+  use xerbla_blas
+  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 xerbla_blas
+  implicit none
+  procedure(xerbla_interface) :: cb
+  active_callback => cb
+end
+
+! A subroutine, not a function returning a procedure pointer: ifx
+! miscompiles references to such a function when the caller declares
+! it through an interface body (ICE in 2025.1, a call through a null
+! pointer in 2026.1).
+subroutine get_blas_xerbla(cb)
+  use xerbla_blas
+  implicit none
+  procedure(xerbla_interface), pointer, intent(out) :: cb
+  cb => active_callback
+end

BLAS/TESTING/cblat1.f

@@ -54,15 +54,18 @@ PROGRAM CBLAT1
       REAL             S1, S2
       REAL             SFAC
       INTEGER          IC
+      INTEGER          VERS_MAJOR, VERS_MINOR, VERS_PATCH
 *     .. External Subroutines ..
-      EXTERNAL         CHECK0, CHECK1, CHECK2, HEADER
+      EXTERNAL         CHECK0, CHECK1, CHECK2, HEADER, IBLAVER
 *     .. Common blocks ..
       COMMON           /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
       COMMON           /CNTBLA/NTESTS, NFAILS
       COMMON           /NAMBLA/SUBNAM
 *     .. Data statements ..
       DATA             SFAC/9.765625E-4/
 *     .. Executable Statements ..
+      CALL IBLAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+      WRITE (NOUT,99995) VERS_MAJOR, VERS_MINOR, VERS_PATCH
       CALL CPU_TIME( S1 )
       WRITE (NOUT,99999)
       DO 20 IC = 1, 14
@@ -101,6 +104,7 @@ PROGRAM CBLAT1
 99997 FORMAT (1X,A6,' COMPUTATIONAL TESTS:',I9,' RUN,',I9,
      +        ' FAILED')
 99996 FORMAT (' Total time used = ',F12.2,' seconds',/)
+99995 FORMAT (/ ' BLAS VERSION ', I1, '.', I2, '.', I1)
 *
 *     End of CBLAT1
 *

BLAS/TESTING/cblat2.f

@@ -126,7 +126,7 @@ PROGRAM CBLAT2
       REAL               S1, S2
       REAL               EPS, ERR, THRESH
       INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
-     $                   NOUT, NTRA
+     $                   NOUT, NTRA, VERS_MAJOR, VERS_MINOR, VERS_PATCH
       LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
      $                   TSTERR
       CHARACTER*1        TRANS
@@ -149,7 +149,8 @@ PROGRAM CBLAT2
       EXTERNAL           SDIFF, LCE
 *     .. External Subroutines ..
       EXTERNAL           CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHK6,
-     $                   CCHKE, CMVCH
+     $                   CCHKE, CMVCH, SET_BLAS_XERBLA, XER_REPLACE,
+     $                   IBLAVER
 *     .. Intrinsic Functions ..
       INTRINSIC          ABS, MAX, MIN
 *     .. Scalars in Common ..
@@ -165,15 +166,31 @@ PROGRAM CBLAT2
      $                   'CTRSV ', 'CTBSV ', 'CTPSV ', 'CGERC ',
      $                   'CGERU ', 'CHER  ', 'CHPR  ', 'CHER2 ',
      $                   'CHPR2 '/
+      INTERFACE
+        SUBROUTINE XERBLA_INTERFACE(SRNAME, INFO)
+          CHARACTER*(*), INTENT(IN) :: SRNAME
+          INTEGER, INTENT(IN) :: INFO
+        END SUBROUTINE
+        SUBROUTINE GET_BLAS_XERBLA(CB)
+          IMPORT :: XERBLA_INTERFACE
+          IMPLICIT NONE
+          PROCEDURE(XERBLA_INTERFACE), POINTER, INTENT(OUT) :: CB
+        END SUBROUTINE
+      END INTERFACE
+      PROCEDURE(XERBLA_INTERFACE), POINTER :: ALREADY_CB
 *     .. Executable Statements ..
       CALL CPU_TIME( S1 )
+      CALL GET_BLAS_XERBLA(ALREADY_CB)
+      CALL SET_BLAS_XERBLA(XER_REPLACE)
 *
 *     Read name and unit number for summary output file and open file.
 *
       READ( NIN, FMT = * )SUMMRY
       READ( NIN, FMT = * )NOUT
       OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
       NOUTC = NOUT
+      CALL IBLAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+      WRITE (NOUT,9978) VERS_MAJOR, VERS_MINOR, VERS_PATCH
 *
 *     Read name and unit number for snapshot output file and open file.
 *
@@ -434,6 +451,7 @@ PROGRAM CBLAT2
  9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
  9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
  9979 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
+ 9978 FORMAT (/ ' BLAS VERSION ', I1, '.', I2, '.', I1)
 *
 *     End of CBLAT2
 *
@@ -3403,7 +3421,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