diff --git a/.github/workflows/compilers.yml b/.github/workflows/compilers.yml index 4c5edc9e0c..a28ae1de37 100644 --- a/.github/workflows/compilers.yml +++ b/.github/workflows/compilers.yml @@ -77,7 +77,7 @@ jobs: CC: ${{ matrix.toolchain.CC }} FFLAGS: ${{ matrix.toolchain.FFLAGS }} CFLAGS: ${{ matrix.toolchain.CFLAGS }} - JOB_ID: ${{ matrix.toolchain.os }}-${{ matrix.toolchain.FC }}-${{ matrix.lib_type }} + JOB_ID: ${{ matrix.toolchain.os }}-${{ matrix.toolchain.FC }}${{ matrix.toolchain.flat_namespace && '-flat' || '' }}-${{ matrix.lib_type }} strategy: fail-fast: false @@ -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 @@ -439,7 +445,7 @@ jobs: if: ${{ !cancelled() && env.SKIP_TOOLCHAIN != 'true' }} uses: actions/upload-artifact@043fb46d1a93c77aae656e7c1c64a875d1fc6a0a # v7.0.1 with: - name: test-results-${{ matrix.toolchain.FC }}-${{ matrix.toolchain.os }}-${{ matrix.lib_type }} + name: test-results-${{ env.JOB_ID }} path: | build/TESTING/testing_results.txt build/lapack_testing_junit.xml @@ -461,7 +467,7 @@ jobs: # The report is named above, so there is nothing to search the tree for. disable_search: true flags: tests-${{ env.JOB_ID }} - name: ${{ matrix.toolchain.os }}-${{ matrix.toolchain.FC }} (${{ matrix.lib_type }}) + name: ${{ env.JOB_ID }} fail_ci_if_error: true verbose: true diff --git a/.gitignore b/.gitignore index d5868d358f..c9b9950723 100644 --- a/.gitignore +++ b/.gitignore @@ -15,7 +15,11 @@ make.inc BLAS/TESTING/*.out BLAS/TESTING/x* +# Mod files from compilation in BLAS/SRC +BLAS/SRC/xerbla_blas.mod + # CBLAS +CBLAS/include/cblas.h CBLAS/include/cblas_mangling.h CBLAS/include/cblas_f77.h @@ -57,3 +61,4 @@ output_err # Mod files from compilation in SRC SRC/la_constants.mod SRC/la_xisnan.mod +SRC/xerbla_lapack.mod diff --git a/BLAS/SRC/CMakeLists.txt b/BLAS/SRC/CMakeLists.txt index aa725c971a..8a03524546 100644 --- a/BLAS/SRC/CMakeLists.txt +++ b/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 diff --git a/BLAS/SRC/Makefile b/BLAS/SRC/Makefile index 1a0816c83d..8c99427ad8 100644 --- a/BLAS/SRC/Makefile +++ b/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 diff --git a/BLAS/SRC/iblaver.f b/BLAS/SRC/iblaver.f new file mode 100644 index 0000000000..131969e4d7 --- /dev/null +++ b/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 diff --git a/BLAS/SRC/xerbla.f b/BLAS/SRC/xerbla.f index 622f91959b..7608468846 100644 --- a/BLAS/SRC/xerbla.f +++ b/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. See separate documentation in +*> xerbla_blas.f90. +*> *> 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 XERBLA_BLAS IMPLICIT NONE * * -- Reference BLAS level1 routine -- @@ -72,9 +77,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 diff --git a/BLAS/SRC/xerbla_blas.f90 b/BLAS/SRC/xerbla_blas.f90 new file mode 100644 index 0000000000..65b40a276a --- /dev/null +++ b/BLAS/SRC/xerbla_blas.f90 @@ -0,0 +1,112 @@ +!> \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 a NULL value, +!> although this is only possible via a C interface as it is forbidden +!> in the Fortran standard. +!> +!> Users should usually also use SET_LAPACK_XERBLA since the error +!> handlers may be separate due to the vagaries of linkage. +!> 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 2 + 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 diff --git a/BLAS/TESTING/cblat1.f b/BLAS/TESTING/cblat1.f index dfc36e7a78..549db8e05b 100644 --- a/BLAS/TESTING/cblat1.f +++ b/BLAS/TESTING/cblat1.f @@ -54,8 +54,9 @@ 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 @@ -63,6 +64,8 @@ PROGRAM CBLAT1 * .. 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 * diff --git a/BLAS/TESTING/cblat2.f b/BLAS/TESTING/cblat2.f index e8657213dd..6525aed736 100644 --- a/BLAS/TESTING/cblat2.f +++ b/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,8 +166,22 @@ 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. * @@ -174,6 +189,8 @@ PROGRAM CBLAT2 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 diff --git a/BLAS/TESTING/cblat3.f b/BLAS/TESTING/cblat3.f index d3ff49c427..a939334fd8 100644 --- a/BLAS/TESTING/cblat3.f +++ b/BLAS/TESTING/cblat3.f @@ -107,7 +107,8 @@ PROGRAM CBLAT3 * .. Local Scalars .. REAL S1, S2 REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA, + $ VERS_MAJOR, VERS_MINOR, VERS_PATCH LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB @@ -130,7 +131,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, IBLAVER * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. @@ -146,6 +147,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. * @@ -153,6 +155,8 @@ PROGRAM CBLAT3 READ( NIN, FMT = * )NOUT OPEN( NOUT, FILE = SUMMRY ) NOUTC = NOUT + CALL IBLAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + WRITE (NOUT,9982) VERS_MAJOR, VERS_MINOR, VERS_PATCH * * Read name and unit number for snapshot output file and open file. * @@ -409,6 +413,7 @@ PROGRAM CBLAT3 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 9983 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) + 9982 FORMAT (/ ' BLAS VERSION ', I1, '.', I2, '.', I1) * * End of CBLAT3 * @@ -3726,7 +3731,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 diff --git a/BLAS/TESTING/dblat1.f b/BLAS/TESTING/dblat1.f index 19c219461f..a7524ab121 100644 --- a/BLAS/TESTING/dblat1.f +++ b/BLAS/TESTING/dblat1.f @@ -54,8 +54,9 @@ PROGRAM DBLAT1 DOUBLE PRECISION S1, S2 DOUBLE PRECISION SFAC INTEGER IC + INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * .. External Subroutines .. - EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER + EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER, IBLAVER * .. Common blocks .. COMMON /COMBLA/ICASE, N, INCX, INCY, PASS COMMON /CNTBLA/NTESTS, NFAILS @@ -63,6 +64,8 @@ PROGRAM DBLAT1 * .. Data statements .. DATA SFAC/9.765625D-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 @@ -104,6 +107,7 @@ PROGRAM DBLAT1 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 DBLAT1 * diff --git a/BLAS/TESTING/dblat2.f b/BLAS/TESTING/dblat2.f index 8fbc4ca3b8..8e2eb2bc34 100644 --- a/BLAS/TESTING/dblat2.f +++ b/BLAS/TESTING/dblat2.f @@ -125,7 +125,7 @@ PROGRAM DBLAT2 DOUBLE PRECISION S1, S2 DOUBLE PRECISION 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 @@ -147,7 +147,8 @@ PROGRAM DBLAT2 EXTERNAL DDIFF, LDE * .. External Subroutines .. EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6, - $ DCHKE, DMVCH + $ DCHKE, DMVCH, SET_BLAS_XERBLA, XER_REPLACE, + $ IBLAVER * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. Scalars in Common .. @@ -169,6 +170,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. * @@ -176,6 +178,8 @@ PROGRAM DBLAT2 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. * @@ -433,6 +437,7 @@ PROGRAM DBLAT2 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 DBLAT2 * @@ -3385,7 +3390,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 diff --git a/BLAS/TESTING/dblat3.f b/BLAS/TESTING/dblat3.f index 9449d7749c..27917a9e55 100644 --- a/BLAS/TESTING/dblat3.f +++ b/BLAS/TESTING/dblat3.f @@ -104,7 +104,8 @@ PROGRAM DBLAT3 * .. Local Scalars .. DOUBLE PRECISION S1, S2 DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA, + $ VERS_MAJOR, VERS_MINOR, VERS_PATCH LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB @@ -126,7 +127,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, IBLAVER * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. @@ -144,6 +145,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. * @@ -151,6 +153,8 @@ PROGRAM DBLAT3 READ( NIN, FMT = * )NOUT OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT + CALL IBLAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + WRITE (NOUT,9982) VERS_MAJOR, VERS_MINOR, VERS_PATCH * * Read name and unit number for snapshot output file and open file. * @@ -404,6 +408,7 @@ PROGRAM DBLAT3 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 9983 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) + 9982 FORMAT (/ ' BLAS VERSION ', I1, '.', I2, '.', I1) * * End of DBLAT3 * @@ -3204,7 +3209,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 diff --git a/BLAS/TESTING/sblat1.f b/BLAS/TESTING/sblat1.f index c4db0342d1..49fed70681 100644 --- a/BLAS/TESTING/sblat1.f +++ b/BLAS/TESTING/sblat1.f @@ -54,8 +54,9 @@ PROGRAM SBLAT1 REAL S1, S2 REAL SFAC INTEGER IC + INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH * .. External Subroutines .. - EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER + EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER, IBLAVER * .. Common blocks .. COMMON /COMBLA/ICASE, N, INCX, INCY, PASS COMMON /CNTBLA/NTESTS, NFAILS @@ -63,6 +64,8 @@ PROGRAM SBLAT1 * .. 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 @@ -104,6 +107,7 @@ PROGRAM SBLAT1 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 SBLAT1 * diff --git a/BLAS/TESTING/sblat2.f b/BLAS/TESTING/sblat2.f index b8cbccc8a4..9bc7ff43c9 100644 --- a/BLAS/TESTING/sblat2.f +++ b/BLAS/TESTING/sblat2.f @@ -125,7 +125,7 @@ PROGRAM SBLAT2 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 @@ -147,7 +147,8 @@ PROGRAM SBLAT2 EXTERNAL SDIFF, LSE * .. External Subroutines .. EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHK6, - $ SCHKE, SMVCH + $ SCHKE, SMVCH, SET_BLAS_XERBLA, XER_REPLACE, + $ IBLAVER * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. Scalars in Common .. @@ -169,6 +170,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. * @@ -176,6 +178,8 @@ PROGRAM SBLAT2 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 +438,7 @@ PROGRAM SBLAT2 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 SBLAT2 * @@ -3385,7 +3390,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 diff --git a/BLAS/TESTING/sblat3.f b/BLAS/TESTING/sblat3.f index d6ca9dce76..03f4951f19 100644 --- a/BLAS/TESTING/sblat3.f +++ b/BLAS/TESTING/sblat3.f @@ -104,7 +104,8 @@ PROGRAM SBLAT3 * .. Local Scalars .. REAL S1, S2 REAL EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA, + $ VERS_MAJOR, VERS_MINOR, VERS_PATCH LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB @@ -126,7 +127,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, IBLAVER * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. @@ -144,6 +145,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. * @@ -151,6 +153,8 @@ PROGRAM SBLAT3 READ( NIN, FMT = * )NOUT OPEN( NOUT, FILE = SUMMRY ) NOUTC = NOUT + CALL IBLAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + WRITE (NOUT,9982) VERS_MAJOR, VERS_MINOR, VERS_PATCH * * Read name and unit number for snapshot output file and open file. * @@ -405,6 +409,7 @@ PROGRAM SBLAT3 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 9983 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) + 9982 FORMAT (/ ' BLAS VERSION ', I1, '.', I2, '.', I1) * * End of SBLAT3 * @@ -3205,7 +3210,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 diff --git a/BLAS/TESTING/zblat1.f b/BLAS/TESTING/zblat1.f index fcddf6bdeb..fe08ec606b 100644 --- a/BLAS/TESTING/zblat1.f +++ b/BLAS/TESTING/zblat1.f @@ -54,8 +54,9 @@ PROGRAM ZBLAT1 DOUBLE PRECISION S1, S2 DOUBLE PRECISION 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 @@ -63,6 +64,8 @@ PROGRAM ZBLAT1 * .. Data statements .. DATA SFAC/9.765625D-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 ZBLAT1 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 ZBLAT1 * diff --git a/BLAS/TESTING/zblat2.f b/BLAS/TESTING/zblat2.f index 8069d499ea..5cb3c341e9 100644 --- a/BLAS/TESTING/zblat2.f +++ b/BLAS/TESTING/zblat2.f @@ -127,7 +127,7 @@ PROGRAM ZBLAT2 DOUBLE PRECISION S1, S2 DOUBLE PRECISION 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 @@ -150,7 +150,8 @@ PROGRAM ZBLAT2 EXTERNAL DDIFF, LZE * .. External Subroutines .. EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6, - $ ZCHKE, ZMVCH + $ ZCHKE, ZMVCH, SET_BLAS_XERBLA, XER_REPLACE, + $ IBLAVER * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. Scalars in Common .. @@ -168,6 +169,7 @@ PROGRAM ZBLAT2 $ 'ZHPR2 '/ * .. Executable Statements .. CALL CPU_TIME( S1 ) + CALL SET_BLAS_XERBLA(XER_REPLACE) * * Read name and unit number for summary output file and open file. * @@ -175,6 +177,8 @@ PROGRAM ZBLAT2 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 +438,7 @@ PROGRAM ZBLAT2 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 ZBLAT2 * @@ -3424,7 +3429,7 @@ SUBROUTINE ZREGR1( 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 diff --git a/BLAS/TESTING/zblat3.f b/BLAS/TESTING/zblat3.f index a44639c86d..91aaa59eea 100644 --- a/BLAS/TESTING/zblat3.f +++ b/BLAS/TESTING/zblat3.f @@ -109,7 +109,8 @@ PROGRAM ZBLAT3 * .. Local Scalars .. DOUBLE PRECISION S1, S2 DOUBLE PRECISION EPS, ERR, THRESH - INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA + INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA, + $ VERS_MAJOR, VERS_MINOR, VERS_PATCH LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB @@ -132,7 +133,8 @@ PROGRAM ZBLAT3 EXTERNAL DDIFF, LZE * .. External Subroutines .. EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHK6 - EXTERNAL ZCHKE, ZMMCH + EXTERNAL ZCHKE, ZMMCH, SET_BLAS_XERBLA, XER_REPLACE, + $ IBLAVER * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. @@ -148,6 +150,7 @@ PROGRAM ZBLAT3 $ 'ZSYR2K', 'ZGEMMTR'/ * .. Executable Statements .. CALL CPU_TIME( S1 ) + CALL SET_BLAS_XERBLA(XER_REPLACE) * * Read name and unit number for summary output file and open file. * @@ -155,6 +158,8 @@ PROGRAM ZBLAT3 READ( NIN, FMT = * )NOUT OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT + CALL IBLAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + WRITE (NOUT,9982) VERS_MAJOR, VERS_MINOR, VERS_PATCH * * Read name and unit number for snapshot output file and open file. * @@ -412,6 +417,7 @@ PROGRAM ZBLAT3 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) 9983 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) + 9982 FORMAT (/ ' BLAS VERSION ', I1, '.', I2, '.', I1) * * End of ZBLAT3 * @@ -3750,7 +3756,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 diff --git a/CBLAS/Makefile b/CBLAS/Makefile index 291a19abe2..bae07da524 100644 --- a/CBLAS/Makefile +++ b/CBLAS/Makefile @@ -4,10 +4,15 @@ include $(TOPSRCDIR)/make.inc .PHONY: all all: cblas +CBLAS_INCLUDES = include/cblas.h include/cblas_mangling.h include/cblas_f77.h + .PHONY: cblas -cblas: include/cblas_mangling.h include/cblas_f77.h +cblas: $(CBLAS_INCLUDES) $(MAKE) -C src +include/cblas.h: include/cblas.h.in + sed 's/@FORTRAN_STRLEN_TYPE@/size_t/' $< > $@.tmp && mv $@.tmp $@ + include/cblas_mangling.h: include/cblas_mangling_with_flags.h.in cp $< $@ @@ -27,7 +32,7 @@ clean: $(MAKE) -C src clean $(MAKE) -C testing clean $(MAKE) -C examples clean - rm -f include/cblas_mangling.h include/cblas_f77.h + rm -f $(CBLAS_INCLUDES) cleanobj: $(MAKE) -C src cleanobj $(MAKE) -C testing cleanobj diff --git a/CBLAS/include/CMakeLists.txt b/CBLAS/include/CMakeLists.txt index 6ed2f0db14..58e897c2b7 100644 --- a/CBLAS/include/CMakeLists.txt +++ b/CBLAS/include/CMakeLists.txt @@ -10,8 +10,9 @@ install( if(CBLAS) set(CBLAS_INCLUDE cblas.h cblas_64.h) - configure_file(cblas.h ${LAPACK_BINARY_DIR}/include/cblas.h COPYONLY) + configure_file(cblas.h.in ${LAPACK_BINARY_DIR}/include/cblas.h) configure_file(cblas_64.h ${LAPACK_BINARY_DIR}/include/cblas_64.h COPYONLY) + list(TRANSFORM CBLAS_INCLUDE PREPEND "${LAPACK_BINARY_DIR}/include/") install(FILES ${CBLAS_INCLUDE} DESTINATION ${CMAKE_INSTALL_INCLUDEDIR} COMPONENT Development) diff --git a/CBLAS/include/cblas.h b/CBLAS/include/cblas.h.in similarity index 97% rename from CBLAS/include/cblas.h rename to CBLAS/include/cblas.h.in index d840bc944a..ba7a488935 100644 --- a/CBLAS/include/cblas.h +++ b/CBLAS/include/cblas.h.in @@ -2,6 +2,7 @@ #define CBLAS_H #include #include +#include #include @@ -25,6 +26,14 @@ extern "C" { /* Assume C declarations for C++ */ #endif #endif +#ifndef F77_INT +#define F77_INT CBLAS_INT +#endif + +#ifndef FORTRAN_STRLEN + #define FORTRAN_STRLEN @FORTRAN_STRLEN_TYPE@ +#endif + /* * Integer format string */ @@ -699,8 +708,16 @@ void cblas_zher2k(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const void *B, const CBLAS_INT ldb, const double beta, void *C, const CBLAS_INT ldc); -void CBLAS_WEAK_SYMBOL cblas_xerbla(CBLAS_INT p, const char *rout, - const char *form, ...); +typedef void (*blas_fortran_xerbla_callback_t)(char *F77_srname, F77_INT *info, FORTRAN_STRLEN len); +#define CBLAS_XERBLA_ARGS \ + (CBLAS_INT p, const char *rout, const char *form, ...) +#define CBLAS_XERBLA_CALLBACK_ARGS \ + (CBLAS_INT p, const char *rout, const char *form, va_list ap) +typedef void (*cblas_xerbla_callback_t) CBLAS_XERBLA_CALLBACK_ARGS; +void CBLAS_WEAK_SYMBOL cblas_xerbla CBLAS_XERBLA_ARGS; +cblas_xerbla_callback_t cblas_get_xerbla(void); +cblas_xerbla_callback_t cblas_set_xerbla(cblas_xerbla_callback_t cb, blas_fortran_xerbla_callback_t F77_cb); +void cblas_iblaver(CBLAS_INT *major, CBLAS_INT *minor, CBLAS_INT *patch); #ifdef __cplusplus } diff --git a/CBLAS/include/cblas_64.h b/CBLAS/include/cblas_64.h index 32009bd2dd..6f71e3b2b9 100644 --- a/CBLAS/include/cblas_64.h +++ b/CBLAS/include/cblas_64.h @@ -2,6 +2,7 @@ #define CBLAS_64_H #include #include +#include #include #include "cblas.h" @@ -639,8 +640,16 @@ void cblas_zher2k_64(CBLAS_LAYOUT layout, CBLAS_UPLO Uplo, const void *B, const int64_t ldb, const double beta, void *C, const int64_t ldc); -void CBLAS_WEAK_SYMBOL cblas_xerbla_64(int64_t p, const char *rout, - const char *form, ...); +typedef void (*blas_fortran_xerbla_64_callback_t)(char *F77_srname, int64_t *info, FORTRAN_STRLEN len); +#define CBLAS_XERBLA_64_ARGS \ + (int64_t p, const char *rout, const char *form, ...) +#define CBLAS_XERBLA_64_CALLBACK_ARGS \ + (int64_t p, const char *rout, const char *form, va_list ap) +typedef void (*cblas_xerbla_64_callback_t) CBLAS_XERBLA_64_CALLBACK_ARGS; +void CBLAS_WEAK_SYMBOL cblas_xerbla_64 CBLAS_XERBLA_64_ARGS; +cblas_xerbla_64_callback_t cblas_get_xerbla_64(void); +cblas_xerbla_64_callback_t cblas_set_xerbla_64(cblas_xerbla_64_callback_t cb, blas_fortran_xerbla_64_callback_t F77_cb); +void cblas_iblaver_64(int64_t *major, int64_t *minor, int64_t *patch); #ifdef __cplusplus } diff --git a/CBLAS/include/cblas_f77.h.in b/CBLAS/include/cblas_f77.h.in index dbedefcb5e..81bfb07135 100644 --- a/CBLAS/include/cblas_f77.h.in +++ b/CBLAS/include/cblas_f77.h.in @@ -78,6 +78,8 @@ */ #define F77_xerbla_base F77_GLOBAL_SUFFIX(xerbla,XERBLA) +#define F77_get_blas_xerbla_base F77_GLOBAL_SUFFIX(get_blas_xerbla,GET_BLAS_XERBLA) +#define F77_set_blas_xerbla_base F77_GLOBAL_SUFFIX(set_blas_xerbla,SET_BLAS_XERBLA) #define F77_srotg_base F77_GLOBAL_SUFFIX(srotg,SROTG) #define F77_srotmg_base F77_GLOBAL_SUFFIX(srotmg,SROTMG) #define F77_srot_base F77_GLOBAL_SUFFIX(srot,SROT) @@ -90,6 +92,7 @@ #define F77_scopy_base F77_GLOBAL_SUFFIX(scopy,SCOPY) #define F77_saxpy_base F77_GLOBAL_SUFFIX(saxpy,SAXPY) #define F77_saxpby_base F77_GLOBAL_SUFFIX(saxpby,SAXPBY) +#define F77_iblaver_base F77_GLOBAL_SUFFIX(iblaver,IBLAVER) #define F77_isamax_sub_base F77_GLOBAL_SUFFIX(isamaxsub,ISAMAXSUB) #define F77_dswap_base F77_GLOBAL_SUFFIX(dswap,DSWAP) #define F77_dcopy_base F77_GLOBAL_SUFFIX(dcopy,DCOPY) @@ -271,6 +274,7 @@ #define F77_snrm2_sub(...) F77_snrm2_sub_base(__VA_ARGS__) #define F77_sasum_sub(...) F77_sasum_sub_base(__VA_ARGS__) #define F77_isamax_sub(...) F77_isamax_sub_base(__VA_ARGS__) +#define F77_iblaver(...) F77_iblaver_base(__VA_ARGS__) #define F77_scabs1_sub(...) F77_scabs1_sub_base(__VA_ARGS__) /* Double Precision */ @@ -631,9 +635,18 @@ extern "C" { #define BLAS_FORTRAN_XERBLA_LENARG #endif #define BLAS_FORTRAN_XERBLA_ARGS \ - /*not a func-style macro*/(FCHAR F77_srname, void *vinfo BLAS_FORTRAN_XERBLA_LENARG) + /*not a func-style macro*/(FCHAR F77_srname, FINT2 info BLAS_FORTRAN_XERBLA_LENARG) void CBLAS_WEAK_SYMBOL F77_xerbla_base BLAS_FORTRAN_XERBLA_ARGS; +void API_SUFFIX(cblas_F77_xerbla) BLAS_FORTRAN_XERBLA_ARGS; + +typedef void (*blas_fortran_xerbla_callback_t) BLAS_FORTRAN_XERBLA_ARGS; + +#define F77_get_blas_xerbla(...) F77_get_blas_xerbla_base(__VA_ARGS__) +#define F77_set_blas_xerbla(...) F77_set_blas_xerbla_base(__VA_ARGS__) +void F77_get_blas_xerbla_base(blas_fortran_xerbla_callback_t *); +void F77_set_blas_xerbla_base(blas_fortran_xerbla_callback_t); +void F77_iblaver_base(FINT2, FINT2, FINT2); /* * Level 1 Fortran Prototypes diff --git a/CBLAS/include/cblas_test.h b/CBLAS/include/cblas_test.h index d2d7aff203..ba2613d009 100644 --- a/CBLAS/include/cblas_test.h +++ b/CBLAS/include/cblas_test.h @@ -42,7 +42,7 @@ #define BLAS_FORTRAN_XERBLA_LENARG #endif #define BLAS_FORTRAN_XERBLA_ARGS \ - /*not a func-style macro*/(FCHAR F77_srname, void *vinfo BLAS_FORTRAN_XERBLA_LENARG) + /*not a func-style macro*/(FCHAR F77_srname, F77_INT *info BLAS_FORTRAN_XERBLA_LENARG) #define TRUE 1 #define PASSED 1 @@ -67,6 +67,11 @@ typedef struct { float real; float imag; } CBLAS_TEST_COMPLEX; typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; #define F77_xerbla F77_GLOBAL_SUFFIX(xerbla,XERBLA) +#define F77_get_blas_xerbla F77_GLOBAL_SUFFIX(get_blas_xerbla,GET_BLAS_XERBLA) +#define F77_set_blas_xerbla F77_GLOBAL_SUFFIX(set_blas_xerbla,SET_BLAS_XERBLA) +void F77_get_blas_xerbla(blas_fortran_xerbla_callback_t *); +void F77_set_blas_xerbla(blas_fortran_xerbla_callback_t); + /* * Level 1 BLAS */ @@ -248,4 +253,7 @@ void get_uplo_type(char *type, CBLAS_UPLO *uplo); void get_diag_type(char *type, CBLAS_DIAG *diag); void get_side_type(char *type, CBLAS_SIDE *side); +void API_SUFFIX(cblas_xer_replace) CBLAS_XERBLA_CALLBACK_ARGS; +void API_SUFFIX(xer_replace) BLAS_FORTRAN_XERBLA_ARGS; + #endif /* CBLAS_TEST_H */ diff --git a/CBLAS/src/CMakeLists.txt b/CBLAS/src/CMakeLists.txt index 5e027f4710..e3ebb4c3ca 100644 --- a/CBLAS/src/CMakeLists.txt +++ b/CBLAS/src/CMakeLists.txt @@ -4,7 +4,7 @@ set(COMMON_SOURCES cblas_globals.c) # Error handling routines for level 2 & 3 -set(ERRHAND cblas_xerbla.c xerbla.c) +set(ERRHAND cblas_xerbla.c xerbla.c cblas_iblaver.c) # # diff --git a/CBLAS/src/Makefile b/CBLAS/src/Makefile index 7d949e6660..eb0d0f729e 100644 --- a/CBLAS/src/Makefile +++ b/CBLAS/src/Makefile @@ -11,7 +11,7 @@ include $(TOPSRCDIR)/make.inc all: $(CBLASLIB) # Error handling routines for level 2 & 3 -errhand = cblas_globals.o cblas_xerbla.o xerbla.o +errhand = cblas_globals.o cblas_xerbla.o xerbla.o cblas_iblaver.o # # diff --git a/CBLAS/src/cblas_iblaver.c b/CBLAS/src/cblas_iblaver.c new file mode 100644 index 0000000000..ab7f3f008d --- /dev/null +++ b/CBLAS/src/cblas_iblaver.c @@ -0,0 +1,20 @@ +#include +#include +#include + +#include "cblas.h" +#include "cblas_f77.h" + +/** + * \brief Return CBLAS version. + * + * \param[out] major BLAS major version. + * \param[out] minor BLAS minor version. + * \param[out] patch BLAS patch number. + */ +void API_SUFFIX(cblas_iblaver)(CBLAS_INT *major, + CBLAS_INT *minor, + CBLAS_INT *patch) +{ + F77_iblaver(major, minor, patch); +} diff --git a/CBLAS/src/cblas_xerbla.c b/CBLAS/src/cblas_xerbla.c index a4ceae3b98..27198d497d 100644 --- a/CBLAS/src/cblas_xerbla.c +++ b/CBLAS/src/cblas_xerbla.c @@ -6,11 +6,15 @@ #include "cblas_f77.h" #include "cblas_xerbla_internal.h" +static cblas_xerbla_callback_t active_callback = NULL; + /** * \brief CBLAS error handler: report an invalid argument and terminate. * * Remaps \p info to the CBLAS argument position for row-major calls, writes * the diagnostic to stderr and exits; it does not return to its caller. + * Users can replace this behaviour by calling cblas_set_xerbla with a + * replacement handler. See separate documentation. * * \param[in] info CBLAS argument number, or 0 to report only \p form. * \param[in] rout Routine name, e.g. "cblas_dgemm". @@ -22,24 +26,62 @@ void CBLAS_WEAK_SYMBOL API_SUFFIX(cblas_xerbla)(CBLAS_INT info, const char *form, ...) { extern int RowMajorStrg; - char empty[1] = ""; - info = cblas_xerbla_map_info(info, rout, RowMajorStrg); - if (info) { - char reported[CBLAS_XERBLA_ROUT_BUFFER_SIZE]; - cblas_xerbla_apply_api_suffix(reported, sizeof(reported), rout); - - fprintf(stderr, "Parameter %" CBLAS_IFMT " to routine %s was incorrect\n", - info, reported); - } - va_list argptr; va_start(argptr, form); - vfprintf(stderr, form, argptr); + if (active_callback) { + active_callback(info, rout, form, argptr); + } else { + if (info) { + char reported[CBLAS_XERBLA_ROUT_BUFFER_SIZE]; + cblas_xerbla_apply_api_suffix(reported, sizeof(reported), rout); + fprintf(stderr, "Parameter %" CBLAS_IFMT " to routine %s was incorrect\n", + info, reported); + } + vfprintf(stderr, form, argptr); + } va_end(argptr); + if (!active_callback) + exit(-1); +} - if (info && !info) { - F77_xerbla(empty, &info); /* Force link of our F77 error handler */ - } - exit(-1); +/** + * \brief Override cblas_xerbla handler. + * + * Returns the old CBLAS handler. + * + * The new handler takes a va_list argument instead of the "...". The + * info parameter will already have been mapped from its Fortran value + * so you don't need to do that in your handler. + * Users should usually also use LAPACKE_set_xerbla since the error + * handlers may be separate due to the vagaries of linkage. + * + * If users wish to chain their handlers, calling other + * previously-registered ones after their own, they must be careful + * not to create loops. + * + * \param[in] cblas_xerbla_ptr Pointer to a cblas_xerbla replacement. + * Call with NULL to restore default behaviour. + * \param[in] F77_xerbla_ptr Pointer to a Fortran-compatible XERBLA + * replacement. Call with NULL if no control + * over Fortran-originated errors is desired; + * the override mechanism will do the right thing. + */ +cblas_xerbla_callback_t API_SUFFIX(cblas_set_xerbla)(cblas_xerbla_callback_t cb, blas_fortran_xerbla_callback_t F77_cb) +{ + cblas_xerbla_callback_t old_cb = active_callback; + active_callback = cb; + F77_set_blas_xerbla_base( + cb ? (F77_cb ? F77_cb : API_SUFFIX(cblas_F77_xerbla)) /* set up new handler */ + : NULL /* restore default */ + ); + return old_cb; +} + +/** + * \brief Returns the current cblas_xerbla handler. + */ +cblas_xerbla_callback_t API_SUFFIX(cblas_get_xerbla)(void) +{ + return active_callback; } diff --git a/CBLAS/src/xerbla.c b/CBLAS/src/xerbla.c index 3034eedb9c..ee63388c8e 100644 --- a/CBLAS/src/xerbla.c +++ b/CBLAS/src/xerbla.c @@ -4,22 +4,12 @@ #include "cblas_f77.h" #include "cblas_xerbla_internal.h" -/** - * \brief XERBLA implementation linked in together with the CBLAS library. - * - * An error raised beneath a CBLAS wrapper is forwarded to cblas_xerbla() - * under the CBLAS spelling of the routine name, with the argument number - * shifted by one to account for the extra layout argument. Errors from - * direct Fortran calls are reported under the Fortran name instead. - * - * \param[in] F77_srname Routine name reported by the Fortran BLAS, blank - * padded and not NUL terminated. - * \param[in] vinfo Pointer to the Fortran argument number. - * \param[in] len Hidden Fortran length of \p F77_srname, on - * compilers that pass string lengths at the end of - * the argument list. - */ -void CBLAS_WEAK_SYMBOL F77_xerbla_base BLAS_FORTRAN_XERBLA_ARGS +static blas_fortran_xerbla_callback_t active_callback = NULL; + +/* This is a separate function so it can be injected when user wants + to override cblas_xerbla, but XERBLA can be overridden with + linker stuff. */ +void API_SUFFIX(cblas_F77_xerbla) BLAS_FORTRAN_XERBLA_ARGS { extern int CBLAS_CallFromC; @@ -35,13 +25,18 @@ void CBLAS_WEAK_SYMBOL F77_xerbla_base BLAS_FORTRAN_XERBLA_ARGS const char *srname = F77_srname; #endif - const F77_INT *info = (const F77_INT *)vinfo; const CBLAS_INT cblas_info = (CBLAS_INT)*info; if (CBLAS_CallFromC) { char rout[CBLAS_XERBLA_ROUT_BUFFER_SIZE]; cblas_xerbla_make_rout(rout, sizeof(rout), srname, srname_len); API_SUFFIX(cblas_xerbla)(cblas_info + 1, rout, ""); + } else if (active_callback && active_callback != API_SUFFIX(cblas_F77_xerbla)) { + active_callback(F77_srname, info +#ifdef BLAS_FORTRAN_STRLEN_END + , len +#endif + ); } else { const size_t display_len = cblas_xerbla_trimmed_length(srname, srname_len); @@ -53,3 +48,57 @@ void CBLAS_WEAK_SYMBOL F77_xerbla_base BLAS_FORTRAN_XERBLA_ARGS fputs(" was incorrect\n", stderr); } } + +/* This means CBLAS calls to these on macOS/Windows then go straight to +the BLAS one, thereby influencing its operation, and defeating the +2-level namespace problem */ +#if !defined(_WIN32) && !defined(__APPLE__) +/** + * \brief XERBLA implementation linked in together with the CBLAS library. + * + * An error raised beneath a CBLAS wrapper is forwarded to cblas_xerbla() + * under the CBLAS spelling of the routine name, with the argument number + * shifted by one to account for the extra layout argument. Errors from + * direct Fortran calls are reported under the Fortran name instead. + * As with the Fortran XERBLA, users can replace the Fortran behaviour by + * calling SET_BLAS_XERBLA (replicated within CBLAS) with a replacement + * handler. See separate documentation. + * + * \param[in] F77_srname Routine name reported by the Fortran BLAS, blank + * padded and not NUL terminated. + * \param[in] info Pointer to the Fortran argument number. + * \param[in] len Hidden Fortran length of \p F77_srname, on + * compilers that pass string lengths at the end of + * the argument list. + */ +void CBLAS_WEAK_SYMBOL F77_xerbla_base BLAS_FORTRAN_XERBLA_ARGS +{ + API_SUFFIX(cblas_F77_xerbla)(F77_srname, info +#ifdef BLAS_FORTRAN_STRLEN_END + , len +#endif + ); +} + +/** + * \brief Override XERBLA handler within BLAS library. + * + * \param[in] fnptr Pointer to a Fortran-compatible XERBLA replacement. + * Call with NULL to restore default behaviour. + */ +void F77_set_blas_xerbla_base(blas_fortran_xerbla_callback_t cb) +{ + active_callback = cb; +} + +/** + * \brief Return the current XERBLA handler within BLAS library. + * + * \param[in] fnptr_ptr Pointer to a pointer to a Fortran-compatible + * XERBLA replacement, mimicking Fortran behaviour. + */ +void F77_get_blas_xerbla_base(blas_fortran_xerbla_callback_t *cb_ret) +{ + *cb_ret = active_callback; +} +#endif diff --git a/CBLAS/testing/c_c2chke.c b/CBLAS/testing/c_c2chke.c index af0af68353..2eb39a3813 100644 --- a/CBLAS/testing/c_c2chke.c +++ b/CBLAS/testing/c_c2chke.c @@ -4,15 +4,11 @@ #include "cblas_test.h" CBLAS_INT cblas_ok, cblas_lerr, cblas_info; -CBLAS_INT link_xerbla=TRUE; CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; char *cblas_rout; -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS; - void chkxer(void) { extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; extern char *cblas_rout; cblas_xtests++; @@ -41,22 +37,14 @@ void F77_c2chke(char *rout RALPHA = 0.0; extern CBLAS_INT cblas_info, cblas_lerr, cblas_ok; extern char *cblas_rout; + blas_fortran_xerbla_callback_t cb; + cblas_xerbla_callback_t cblas_cb; -#ifndef HAS_ATTRIBUTE_WEAK_SUPPORT - #ifdef CBLAS_DLL_IMPORTS - // Since Windows does not support weak symbols, and the trick below doesn't - // work for shared libraries on Windows, we skip the xerbla tests here. - printf("***** WARNING: Skipping xerbla tests since weak symbols are not supported on Windows *****\n"); - return; - #endif - - if (link_xerbla) /* call these first to link */ - { - API_SUFFIX(cblas_xerbla)(cblas_info,cblas_rout,""); - F77_xerbla(cblas_rout,&cblas_info, 1); - } -#endif - link_xerbla = 0; + cblas_cb = API_SUFFIX(cblas_get_xerbla)(); + API_SUFFIX(cblas_set_xerbla)(cblas_cb, NULL); /* uses value */ + F77_get_blas_xerbla(&cb); + F77_set_blas_xerbla(API_SUFFIX(xer_replace)); /* overridden by next, just tests call */ + API_SUFFIX(cblas_set_xerbla)(API_SUFFIX(cblas_xer_replace), API_SUFFIX(xer_replace)); cblas_ok = TRUE ; cblas_lerr = PASSED ; cblas_xtests = 0; @@ -837,6 +825,14 @@ void F77_c2chke(char *rout API_SUFFIX(cblas_chpr)(CblasRowMajor, CblasUpper, 0, RALPHA, X, 0, A ); chkxer(); } + static int version_printed = 0; + if (!version_printed) { + CBLAS_INT major, minor, patch; + API_SUFFIX(cblas_iblaver)(&major, &minor, &patch); + printf(" CBLAS wrapping BLAS version %d.%d.%d\n", + (int)major, (int)minor, (int)patch); + version_printed = 1; + } if (cblas_ok == TRUE) printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout); else diff --git a/CBLAS/testing/c_c3chke.c b/CBLAS/testing/c_c3chke.c index 9dde2bcc09..c749414064 100644 --- a/CBLAS/testing/c_c3chke.c +++ b/CBLAS/testing/c_c3chke.c @@ -4,15 +4,11 @@ #include "cblas_test.h" CBLAS_INT cblas_ok, cblas_lerr, cblas_info; -CBLAS_INT link_xerbla=TRUE; CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; char *cblas_rout; -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS; - void chkxer(void) { extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; extern char *cblas_rout; cblas_xtests++; @@ -48,22 +44,7 @@ void F77_c3chke(char * rout cblas_xfails = 0; cblas_xbad = 0; -#ifndef HAS_ATTRIBUTE_WEAK_SUPPORT - #ifdef CBLAS_DLL_IMPORTS - // Since Windows does not support weak symbols, and the trick below doesn't - // work for shared libraries on Windows, we skip the xerbla tests here. - printf("***** WARNING: Skipping xerbla tests since weak symbols are not supported on Windows *****\n"); - return; - #endif - - if (link_xerbla) /* call these first to link */ - { - API_SUFFIX(cblas_xerbla)(cblas_info,cblas_rout,""); - F77_xerbla(cblas_rout,&cblas_info, 1); - } -#endif - - link_xerbla = 0; + API_SUFFIX(cblas_set_xerbla)(API_SUFFIX(cblas_xer_replace), API_SUFFIX(xer_replace)); if (strncmp( sf,"cblas_cgemmtr" ,13)==0) { cblas_rout = "cblas_cgemmtr" ; diff --git a/CBLAS/testing/c_d2chke.c b/CBLAS/testing/c_d2chke.c index 493b6132d1..6b79b0f019 100644 --- a/CBLAS/testing/c_d2chke.c +++ b/CBLAS/testing/c_d2chke.c @@ -4,15 +4,11 @@ #include "cblas_test.h" CBLAS_INT cblas_ok, cblas_lerr, cblas_info; -CBLAS_INT link_xerbla=TRUE; CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; char *cblas_rout; -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS; - void chkxer(void) { extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; extern char *cblas_rout; cblas_xtests++; @@ -40,22 +36,7 @@ void F77_d2chke(char *rout extern CBLAS_INT cblas_info, cblas_lerr, cblas_ok; extern char *cblas_rout; -#ifndef HAS_ATTRIBUTE_WEAK_SUPPORT - #ifdef CBLAS_DLL_IMPORTS - // Since Windows does not support weak symbols, and the trick below doesn't - // work for shared libraries on Windows, we skip the xerbla tests here. - printf("***** WARNING: Skipping xerbla tests since weak symbols are not supported on Windows *****\n"); - return; - #endif - - if (link_xerbla) /* call these first to link */ - { - API_SUFFIX(cblas_xerbla)(cblas_info,cblas_rout,""); - F77_xerbla(cblas_rout,&cblas_info, 1); - } -#endif - - link_xerbla = 0; + API_SUFFIX(cblas_set_xerbla)(API_SUFFIX(cblas_xer_replace), API_SUFFIX(xer_replace)); cblas_ok = TRUE ; cblas_lerr = PASSED ; cblas_xtests = 0; diff --git a/CBLAS/testing/c_d3chke.c b/CBLAS/testing/c_d3chke.c index 0fe0127a82..ae77f90d73 100644 --- a/CBLAS/testing/c_d3chke.c +++ b/CBLAS/testing/c_d3chke.c @@ -4,15 +4,11 @@ #include "cblas_test.h" CBLAS_INT cblas_ok, cblas_lerr, cblas_info; -CBLAS_INT link_xerbla=TRUE; CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; char *cblas_rout; -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS; - void chkxer(void) { extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; extern char *cblas_rout; cblas_xtests++; @@ -40,22 +36,7 @@ void F77_d3chke(char *rout extern CBLAS_INT cblas_info, cblas_lerr, cblas_ok; extern char *cblas_rout; -#ifndef HAS_ATTRIBUTE_WEAK_SUPPORT - #ifdef CBLAS_DLL_IMPORTS - // Since Windows does not support weak symbols, and the trick below doesn't - // work for shared libraries on Windows, we skip the xerbla tests here. - printf("***** WARNING: Skipping xerbla tests since weak symbols are not supported on Windows *****\n"); - return; - #endif - - if (link_xerbla) /* call these first to link */ - { - API_SUFFIX(cblas_xerbla)(cblas_info,cblas_rout,""); - F77_xerbla(cblas_rout,&cblas_info, 1); - } -#endif - - link_xerbla = 0; + API_SUFFIX(cblas_set_xerbla)(API_SUFFIX(cblas_xer_replace), API_SUFFIX(xer_replace)); cblas_ok = TRUE ; cblas_lerr = PASSED ; cblas_xtests = 0; diff --git a/CBLAS/testing/c_s2chke.c b/CBLAS/testing/c_s2chke.c index 398bf83ee1..4cb1252fac 100644 --- a/CBLAS/testing/c_s2chke.c +++ b/CBLAS/testing/c_s2chke.c @@ -4,15 +4,11 @@ #include "cblas_test.h" CBLAS_INT cblas_ok, cblas_lerr, cblas_info; -CBLAS_INT link_xerbla=TRUE; CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; char *cblas_rout; -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS; - void chkxer(void) { extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; extern char *cblas_rout; cblas_xtests++; @@ -40,22 +36,7 @@ void F77_s2chke(char *rout extern CBLAS_INT cblas_info, cblas_lerr, cblas_ok; extern char *cblas_rout; -#ifndef HAS_ATTRIBUTE_WEAK_SUPPORT - #ifdef CBLAS_DLL_IMPORTS - // Since Windows does not support weak symbols, and the trick below doesn't - // work for shared libraries on Windows, we skip the xerbla tests here. - printf("***** WARNING: Skipping xerbla tests since weak symbols are not supported on Windows *****\n"); - return; - #endif - - if (link_xerbla) /* call these first to link */ - { - API_SUFFIX(cblas_xerbla)(cblas_info,cblas_rout,""); - F77_xerbla(cblas_rout,&cblas_info, 1); - } -#endif - - link_xerbla = 0; + API_SUFFIX(cblas_set_xerbla)(API_SUFFIX(cblas_xer_replace), API_SUFFIX(xer_replace)); cblas_ok = TRUE ; cblas_lerr = PASSED ; cblas_xtests = 0; diff --git a/CBLAS/testing/c_s3chke.c b/CBLAS/testing/c_s3chke.c index bbd17fdfea..018899e787 100644 --- a/CBLAS/testing/c_s3chke.c +++ b/CBLAS/testing/c_s3chke.c @@ -4,15 +4,11 @@ #include "cblas_test.h" CBLAS_INT cblas_ok, cblas_lerr, cblas_info; -CBLAS_INT link_xerbla=TRUE; CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; char *cblas_rout; -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS; - void chkxer(void) { extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; extern char *cblas_rout; cblas_xtests++; @@ -41,22 +37,7 @@ void F77_s3chke(char *rout extern CBLAS_INT cblas_info, cblas_lerr, cblas_ok; extern char *cblas_rout; -#ifndef HAS_ATTRIBUTE_WEAK_SUPPORT - #ifdef CBLAS_DLL_IMPORTS - // Since Windows does not support weak symbols, and the trick below doesn't - // work for shared libraries on Windows, we skip the xerbla tests here. - printf("***** WARNING: Skipping xerbla tests since weak symbols are not supported on Windows *****\n"); - return; - #endif - - if (link_xerbla) /* call these first to link */ - { - API_SUFFIX(cblas_xerbla)(cblas_info,cblas_rout,""); - F77_xerbla(cblas_rout,&cblas_info, 1); - } -#endif - - link_xerbla = 0; + API_SUFFIX(cblas_set_xerbla)(API_SUFFIX(cblas_xer_replace), API_SUFFIX(xer_replace)); cblas_ok = TRUE ; cblas_lerr = PASSED ; cblas_xtests = 0; diff --git a/CBLAS/testing/c_xerbla.c b/CBLAS/testing/c_xerbla.c index ae4d52864c..df55405e5d 100644 --- a/CBLAS/testing/c_xerbla.c +++ b/CBLAS/testing/c_xerbla.c @@ -18,23 +18,15 @@ * \param[in] rout Routine name, e.g. "cblas_dgemm". * \param[in] form Unused; kept so the signature matches the library's. */ -void API_SUFFIX(cblas_xerbla)(CBLAS_INT info, const char *rout, - const char *form, ...) +void API_SUFFIX(cblas_xer_replace)(CBLAS_INT info, const char *rout, + const char *form, va_list ap) { extern CBLAS_INT cblas_lerr, cblas_info, cblas_ok; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xbad; extern char *cblas_rout; (void)form; - /* Initially, c__3chke may call this routine with - * global variable link_xerbla=1, and F77_xerbla will set link_xerbla=0. - * This is done to fool the linker into loading these subroutines first - * instead of ones in the CBLAS or the legacy BLAS library. - */ - if (link_xerbla) return; - /* The name is checked and reported as the user would see it, suffix and * all, while the remapping below keys off the unsuffixed \p rout. The * expected name goes through the same normalisation, since the testers @@ -54,8 +46,6 @@ void API_SUFFIX(cblas_xerbla)(CBLAS_INT info, const char *rout, cblas_xbad = 1; } - info = cblas_xerbla_map_info(info, rout, RowMajorStrg); - if (info != cblas_info) { printf("***** XERBLA WAS CALLED WITH INFO = %" CBLAS_IFMT " INSTEAD OF %" CBLAS_IFMT " in %s *******\n", @@ -76,15 +66,8 @@ void API_SUFFIX(cblas_xerbla)(CBLAS_INT info, const char *rout, * \param[in] len Hidden Fortran length of \p F77_srname, on * compilers that pass string lengths at the end. */ -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS +void API_SUFFIX(xer_replace) BLAS_FORTRAN_XERBLA_ARGS { - /* See the comment in API_SUFFIX(cblas_xerbla)() above */ - extern CBLAS_INT link_xerbla; - if (link_xerbla) { - link_xerbla = 0; - return; - } - #ifdef BLAS_FORTRAN_STRLEN_END const size_t srname_len = len > 0 ? (size_t)len : 0; #else @@ -97,7 +80,6 @@ void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS const char *srname = F77_srname; #endif - const F77_INT *info = (const F77_INT *)vinfo; const CBLAS_INT cblas_info = (CBLAS_INT)*info; char rout[CBLAS_XERBLA_ROUT_BUFFER_SIZE]; diff --git a/CBLAS/testing/c_z2chke.c b/CBLAS/testing/c_z2chke.c index f9f02664e9..b7c402aac9 100644 --- a/CBLAS/testing/c_z2chke.c +++ b/CBLAS/testing/c_z2chke.c @@ -4,15 +4,11 @@ #include "cblas_test.h" CBLAS_INT cblas_ok, cblas_lerr, cblas_info; -CBLAS_INT link_xerbla=TRUE; CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; char *cblas_rout; -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS; - void chkxer(void) { extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; extern char *cblas_rout; cblas_xtests++; @@ -42,22 +38,7 @@ void F77_z2chke(char *rout extern CBLAS_INT cblas_info, cblas_lerr, cblas_ok; extern char *cblas_rout; -#ifndef HAS_ATTRIBUTE_WEAK_SUPPORT - #ifdef CBLAS_DLL_IMPORTS - // Since Windows does not support weak symbols, and the trick below doesn't - // work for shared libraries on Windows, we skip the xerbla tests here. - printf("***** WARNING: Skipping xerbla tests since weak symbols are not supported on Windows *****\n"); - return; - #endif - - if (link_xerbla) /* call these first to link */ - { - API_SUFFIX(cblas_xerbla)(cblas_info,cblas_rout,""); - F77_xerbla(cblas_rout,&cblas_info, 1); - } -#endif - - link_xerbla = 0; + API_SUFFIX(cblas_set_xerbla)(API_SUFFIX(cblas_xer_replace), API_SUFFIX(xer_replace)); cblas_ok = TRUE ; cblas_lerr = PASSED ; cblas_xtests = 0; diff --git a/CBLAS/testing/c_z3chke.c b/CBLAS/testing/c_z3chke.c index 98d212aec2..514f74c1a3 100644 --- a/CBLAS/testing/c_z3chke.c +++ b/CBLAS/testing/c_z3chke.c @@ -4,15 +4,11 @@ #include "cblas_test.h" CBLAS_INT cblas_ok, cblas_lerr, cblas_info; -CBLAS_INT link_xerbla=TRUE; CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; char *cblas_rout; -void F77_xerbla BLAS_FORTRAN_XERBLA_ARGS; - void chkxer(void) { extern CBLAS_INT cblas_ok, cblas_lerr, cblas_info; - extern CBLAS_INT link_xerbla; extern CBLAS_INT cblas_xtests, cblas_xfails, cblas_xbad; extern char *cblas_rout; cblas_xtests++; @@ -48,22 +44,7 @@ void F77_z3chke(char *rout cblas_xfails = 0; cblas_xbad = 0; -#ifndef HAS_ATTRIBUTE_WEAK_SUPPORT - #ifdef CBLAS_DLL_IMPORTS - // Since Windows does not support weak symbols, and the trick below doesn't - // work for shared libraries on Windows, we skip the xerbla tests here. - printf("***** WARNING: Skipping xerbla tests since weak symbols are not supported on Windows *****\n"); - return; - #endif - - if (link_xerbla) /* call these first to link */ - { - API_SUFFIX(cblas_xerbla)(cblas_info,cblas_rout,""); - F77_xerbla(cblas_rout,&cblas_info, 1); - } -#endif - - link_xerbla = 0; + API_SUFFIX(cblas_set_xerbla)(API_SUFFIX(cblas_xer_replace), API_SUFFIX(xer_replace)); if (strncmp( sf,"cblas_zgemmtr" ,13)==0) { cblas_rout = "cblas_zgemmtr" ; diff --git a/CMAKE/LAPACKTestHelpers.cmake b/CMAKE/LAPACKTestHelpers.cmake index 0457798772..5e5a0e7346 100644 --- a/CMAKE/LAPACKTestHelpers.cmake +++ b/CMAKE/LAPACKTestHelpers.cmake @@ -1,32 +1,3 @@ -# The test drivers ship their own XERBLA, which records the expected INFO and -# returns, and rely on it replacing the one in the library, which prints and -# stops. A shared library on Windows always calls the XERBLA it was linked -# with, so the first deliberate illegal argument stops the driver before any -# test runs. CBLAS skips its xerbla tests for the same reason, see -# CBLAS/testing. macOS binds a shared library with a two-level namespace by -# default, which keeps the override from taking effect in the same way; -# USE_FLAT_NAMESPACE restores it, see the top-level CMakeLists.txt. -# -# Recomputed on every configure, so that toggling BUILD_SHARED_LIBS in an -# existing build tree is picked up, but left alone when it was asked for on -# the command line: -D puts it in the cache, which defines it here. -if(NOT DEFINED LAPACK_SKIP_ERROR_EXIT_TESTS) - if(WIN32 AND BUILD_SHARED_LIBS) - set(LAPACK_SKIP_ERROR_EXIT_TESTS ON) - message(STATUS - "Disabling the error-exit tests: the test suite's XERBLA cannot replace " - "the one in a shared library on Windows") - elseif(APPLE AND BUILD_SHARED_LIBS AND NOT USE_FLAT_NAMESPACE) - set(LAPACK_SKIP_ERROR_EXIT_TESTS ON) - message(STATUS - "Disabling the error-exit tests: the test suite's XERBLA cannot replace " - "the one in a shared library bound with the default two-level namespace; " - "configure with -D USE_FLAT_NAMESPACE=ON to run them") - else() - set(LAPACK_SKIP_ERROR_EXIT_TESTS OFF) - endif() -endif() - # nagfor folds expressions that deliberately manufacture an Inf or a NaN # and then rejects the result ("Invalid operand for intrinsic SQRT ... Errors # found during constant propagation"), so the test drivers that do that are @@ -94,8 +65,7 @@ function(lapack_test_input out_var input) set(content "") set(disabled "") - if(EXISTS "${input}" AND - (LAPACK_SKIP_ERROR_EXIT_TESTS OR ARG_DISABLE_ERROR_EXIT_TESTS)) + if(EXISTS "${input}" AND ARG_DISABLE_ERROR_EXIT_TESTS) # The rewrite happens at configure time, so ask CMake to re-run when # ${input} changes; otherwise the build tree goes on serving a copy # made from a version of it that no longer exists. diff --git a/CMakeLists.txt b/CMakeLists.txt index 9a3fcb34bd..4d559c1d57 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -253,7 +253,7 @@ if(BLAS_LIBRARIES) enable_language(Fortran) include(CheckFortranFunctionExists) set(CMAKE_REQUIRED_LIBRARIES ${BLAS_LIBRARIES}) - CHECK_FORTRAN_FUNCTION_EXISTS("dgemm" BLAS_FOUND) + CHECK_FORTRAN_FUNCTION_EXISTS("dgemmtr" BLAS_FOUND) unset(CMAKE_REQUIRED_LIBRARIES) if(BLAS_FOUND) message(STATUS "--> BLAS supplied by user is WORKING, will use ${BLAS_LIBRARIES}.") @@ -709,6 +709,7 @@ if(BUILD_HTML_DOCUMENTATION OR BUILD_MAN_DOCUMENTATION) SRC/VARIANTS BLAS/SRC/lsame.f BLAS/SRC/xerbla.f + BLAS/SRC/xerbla_blas.f90 BLAS/SRC/xerbla_array.f INSTALL/slamchf77.f INSTALL/dlamchf77.f ) diff --git a/LAPACKE/include/lapack.h.in b/LAPACKE/include/lapack.h.in index fac7390fce..1b86bd6a5a 100644 --- a/LAPACKE/include/lapack.h.in +++ b/LAPACKE/include/lapack.h.in @@ -102,6 +102,14 @@ extern "C" { #endif #endif +#ifdef LAPACK_FORTRAN_STRLEN_END +#define LAPACK_FORTRAN_XERBLA_LENARG , FORTRAN_STRLEN len +#else +#define LAPACK_FORTRAN_XERBLA_LENARG +#endif +#define LAPACK_FORTRAN_XERBLA_ARGS \ + /*not a func-style macro*/(char const* F77_srname, lapack_int *info LAPACK_FORTRAN_XERBLA_LENARG) + /* * Integer format string */ @@ -143,6 +151,7 @@ typedef lapack_logical (*LAPACK_C_SELECT2) typedef lapack_logical (*LAPACK_Z_SELECT1) ( const lapack_complex_double* ); typedef lapack_logical (*LAPACK_Z_SELECT2) ( const lapack_complex_double*, const lapack_complex_double* ); +typedef void (*LAPACK_XERBLA) LAPACK_FORTRAN_XERBLA_ARGS; /* * Integer specific API @@ -157,6 +166,14 @@ typedef lapack_logical (*LAPACK_Z_SELECT2) #define LAPACK_GLOBAL_SUFFIX(a,b) LAPACK_GLOBAL(a,b) #endif +#define LAPACK_set_lapack_xerbla_base LAPACK_GLOBAL_SUFFIX(set_lapack_xerbla,SET_LAPACK_XERBLA) +void LAPACK_set_lapack_xerbla_base(LAPACK_XERBLA cb); +#define LAPACK_set_lapack_xerbla(...) LAPACK_set_lapack_xerbla_base(__VA_ARGS__) + +#define LAPACK_get_lapack_xerbla_base LAPACK_GLOBAL_SUFFIX(get_lapack_xerbla,GET_LAPACK_XERBLA) +void LAPACK_get_lapack_xerbla_base(LAPACK_XERBLA *cb); +#define LAPACK_get_lapack_xerbla(...) LAPACK_get_lapack_xerbla_base(__VA_ARGS__) + #define LAPACK_lsame_base LAPACK_GLOBAL_SUFFIX(lsame,LSAME) lapack_logical LAPACK_lsame_base( const char* ca, const char* cb #ifdef LAPACK_FORTRAN_STRLEN_END diff --git a/LAPACKE/include/lapacke.h b/LAPACKE/include/lapacke.h index a0b8cbdf29..2a282c080d 100644 --- a/LAPACKE/include/lapacke.h +++ b/LAPACKE/include/lapacke.h @@ -91,6 +91,11 @@ lapack_complex_double lapack_make_complex_double( double re, double im ); /* C-LAPACK function prototypes */ +typedef void (*lapack_xerbla_callback_t) LAPACKE_XERBLA_ARGS; +typedef void (*lapack_fortran_xerbla_callback_t) LAPACK_FORTRAN_XERBLA_ARGS; +lapack_xerbla_callback_t LAPACKE_get_xerbla(void); +lapack_xerbla_callback_t LAPACKE_set_xerbla(lapack_xerbla_callback_t cb, lapack_fortran_xerbla_callback_t F77_cb); + lapack_int LAPACKE_sbdsdc( int matrix_layout, char uplo, char compq, lapack_int n, float* d, float* e, float* u, lapack_int ldu, float* vt, lapack_int ldvt, float* q, diff --git a/LAPACKE/include/lapacke_64.h b/LAPACKE/include/lapacke_64.h index 017c4f85a0..8d9213b070 100644 --- a/LAPACKE/include/lapacke_64.h +++ b/LAPACKE/include/lapacke_64.h @@ -41,6 +41,11 @@ extern "C" { /* C-LAPACK function prototypes */ +typedef void (*lapack_xerbla_64_callback_t)(const char *name, int64_t info); +typedef void (*lapack_fortran_xerbla_64_callback_t)(char const*F77_srname, int64_t *info, FORTRAN_STRLEN len); +lapack_xerbla_64_callback_t LAPACKE_get_xerbla_64(void); +lapack_xerbla_64_callback_t LAPACKE_set_xerbla_64(lapack_xerbla_64_callback_t cb, lapack_fortran_xerbla_64_callback_t F77_cb); + int64_t LAPACKE_sbdsdc_64( int matrix_layout, char uplo, char compq, int64_t n, float* d, float* e, float* u, int64_t ldu, float* vt, int64_t ldvt, float* q, diff --git a/LAPACKE/testing/high_level/lapacke_high_level_main.c.in b/LAPACKE/testing/high_level/lapacke_high_level_main.c.in index 11c5a9a345..e6d46852c4 100644 --- a/LAPACKE/testing/high_level/lapacke_high_level_main.c.in +++ b/LAPACKE/testing/high_level/lapacke_high_level_main.c.in @@ -23,18 +23,41 @@ static const struct { } lapacke_high_level_tests[] = { @LAPACKE_HIGH_LEVEL_ENTRIES@}; +static char saved_name[32] = { '\0' }; +static lapack_int saved_info = 0; +void LAPACKE_xer_replace LAPACKE_XERBLA_ARGS +{ + strncpy(saved_name, name, sizeof(saved_name)-1); + saved_name[sizeof(saved_name)-1] = '\0'; + saved_info = -info; /* LAPACKE_xerbla is called with negative numbers even though Fortran calls with positive */ +} + int main(int argc, char** argv) { - const size_t test_count = + const size_t test_count = 1 + sizeof(lapacke_high_level_tests) / sizeof(lapacke_high_level_tests[0]); size_t i; int matched = 0; + lapack_int minus_1 = -1, two = 2, one = 1, info = 0; + LAPACK_XERBLA F77_cb; + LAPACK_get_lapack_xerbla(&F77_cb); + LAPACK_set_lapack_xerbla(F77_cb); + API_SUFFIX(LAPACKE_set_xerbla)(LAPACKE_xer_replace, NULL); + LAPACK_sgesv(&minus_1, &minus_1, NULL, &minus_1, NULL, NULL, &minus_1, &info); + if (saved_info != 1 || strncmp("SGESV", saved_name, 5) != 0) { + lapacke_test_failures++; + if (saved_info != 1) + fprintf(stderr, "LAPACKE_xerbla override failed: saved_info=%d\n", (int)saved_info); + else + fprintf(stderr, "LAPACKE_xerbla override failed: name='%s'\n", saved_name); + } + API_SUFFIX(LAPACKE_set_xerbla)(NULL, NULL); /* Route LAPACKE-internal allocations through the counting/failing test * allocator; everything else tests the stock LAPACKE library. */ LAPACKE_set_alloc(lapacke_test_malloc, lapacke_test_free); - for (i = 0; i < test_count; i++) { + for (i = 0; i < test_count-1; i++) { if (argc > 1 && strcmp(argv[1], lapacke_high_level_tests[i].name) != 0) { continue; } @@ -46,13 +69,13 @@ int main(int argc, char** argv) if (argc > 1 && matched == 0) { fprintf(stderr, "unknown test '%s'; available tests:\n", argv[1]); - for (i = 0; i < test_count; i++) { + for (i = 0; i < test_count-1; i++) { fprintf(stderr, " %s\n", lapacke_high_level_tests[i].name); } return 1; } - printf("%d checks, %d failures\n", lapacke_test_checks, + printf("%d checks, %d failures\n", lapacke_test_checks + 1, lapacke_test_failures); return lapacke_test_failures > 125 ? 125 : lapacke_test_failures; } diff --git a/LAPACKE/utils/lapacke_xerbla.c b/LAPACKE/utils/lapacke_xerbla.c index 47a218ce76..c4723937e2 100644 --- a/LAPACKE/utils/lapacke_xerbla.c +++ b/LAPACKE/utils/lapacke_xerbla.c @@ -31,10 +31,17 @@ *****************************************************************************/ #include +#include #include "lapacke_utils.h" +static lapack_xerbla_callback_t active_callback = NULL; + void API_SUFFIX(LAPACKE_xerbla) LAPACKE_XERBLA_ARGS { + if (active_callback) { + active_callback(name, info); + return; + } if( info == LAPACK_WORK_MEMORY_ERROR ) { printf( "Not enough memory to allocate work array in %s\n", name ); } else if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { @@ -43,3 +50,48 @@ void API_SUFFIX(LAPACKE_xerbla) LAPACKE_XERBLA_ARGS printf( "Wrong parameter %d in %s\n", -(int) info, name ); } } + +/* from CBLAS */ +static inline size_t LAPACKE_xerbla_trimmed_length(const char *name, + const size_t name_len) +{ + if (name == NULL) return 0; + size_t actual_len = 0; + while (actual_len < name_len && name[actual_len] != '\0') { + actual_len++; + } + while (actual_len > 0 && name[actual_len - 1] == ' ') { + actual_len--; + } + return actual_len; +} + +static void API_SUFFIX(LAPACKE_F77_xerbla) LAPACK_FORTRAN_XERBLA_ARGS +{ +#ifdef LAPACK_FORTRAN_STRLEN_END + size_t srname_len = len > 0 ? (size_t)len : 0; +#else + size_t srname_len = 6; +#endif + srname_len = MIN(31, LAPACKE_xerbla_trimmed_length(F77_srname,srname_len)); + char srname[32]; /* would use VLA but MSVC no like */ + strncpy(srname, F77_srname, srname_len); + srname[srname_len] = '\0'; + API_SUFFIX(LAPACKE_xerbla)(srname, -(*info)); /* Fortran calls with positive values, LAPACKE wrapper expects negative */ +} + +lapack_xerbla_callback_t API_SUFFIX(LAPACKE_get_xerbla)(void) +{ + return active_callback; +} + +lapack_xerbla_callback_t API_SUFFIX(LAPACKE_set_xerbla)(lapack_xerbla_callback_t cb, lapack_fortran_xerbla_callback_t F77_cb) +{ + lapack_xerbla_callback_t old_cb = active_callback; + active_callback = cb; + LAPACK_set_lapack_xerbla( + cb ? (F77_cb ? F77_cb : API_SUFFIX(LAPACKE_F77_xerbla)) /* set up new handler */ + : NULL /* restore default */ + ); + return old_cb; +} diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index ff32872626..0de0664c36 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -43,7 +43,7 @@ set(NANMOD la_xisnan.F90) set(ALLAUX ilaenv.f ilaenv2stage.f ieeeck.f lsamen.f iparmq.f iparam2stage.F ilaprec.f ilatrans.f ilauplo.f iladiag.f chla_transtype.f ../INSTALL/ilaver.f ../INSTALL/lsame.f xerbla.f xerbla_array.f - ../INSTALL/slamch.f) + ../INSTALL/slamch.f xerbla_lapack.f90) set(SCLAUX sbdsvdx.f sbdsvdmr3.f sbdsvdmr3_work.f sbdtgk.f slar1v_tgk.f slarrf_tgk.f slarrv_tgk.f slarrb_tgk.f sbdsdc.f diff --git a/SRC/Makefile b/SRC/Makefile index 70c56a3ca3..ab1b126be1 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -69,7 +69,7 @@ ALLMOD = la_xisnan.mod la_constants.mod .o.mod: @true -ALLAUX = ilaenv.o ilaenv2stage.o ieeeck.o lsamen.o xerbla.o xerbla_array.o \ +ALLAUX = ilaenv.o ilaenv2stage.o ieeeck.o lsamen.o xerbla.o xerbla_array.o xerbla_lapack.o \ iparmq.o iparam2stage.o la_xisnan.o \ ilaprec.o ilatrans.o ilauplo.o iladiag.o chla_transtype.o \ ../INSTALL/ilaver.o ../INSTALL/lsame.o ../INSTALL/slamch.o @@ -648,8 +648,9 @@ dla_wwaddw.o: dla_wwaddw.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< cla_wwaddw.o: cla_wwaddw.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< zla_wwaddw.o: zla_wwaddw.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< -# Modules +# Modules - these rules are to supersede the implicit ones at top la_xisnan.o: la_xisnan.F90 la_constants.mod $(FC) $(FFLAGS) -c -o $@ $< la_constants.o: la_constants.f90 $(FC) $(FFLAGS) -c -o $@ $< +xerbla.o: xerbla_lapack.o diff --git a/SRC/xerbla.f b/SRC/xerbla.f index 1597a53897..d552e4e358 100644 --- a/SRC/xerbla.f +++ b/SRC/xerbla.f @@ -33,6 +33,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 LAPACK XERBLA by calling SET_LAPACK_XERBLA +*> with a replacement handler. See separate documentation in +*> xerbla_lapack.f90. +*> *> Installers may consider modifying the STOP statement in order to *> call system-specific exception-handling facilities. *> \endverbatim @@ -65,6 +69,7 @@ * * ===================================================================== SUBROUTINE XERBLA( SRNAME, INFO ) + USE XERBLA_LAPACK IMPLICIT NONE * * -- LAPACK auxiliary routine -- @@ -80,9 +85,14 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * * .. Intrinsic Functions .. INTRINSIC LEN_TRIM + EXTERNAL XERBLA_LAPACK_SUB * .. * .. Executable Statements .. * + IF (ASSOCIATED(ACTIVE_CALLBACK)) THEN + CALL XERBLA_LAPACK_SUB(SRNAME, INFO) + RETURN + END IF WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO * STOP diff --git a/SRC/xerbla_lapack.f90 b/SRC/xerbla_lapack.f90 new file mode 100644 index 0000000000..80a52b8e96 --- /dev/null +++ b/SRC/xerbla_lapack.f90 @@ -0,0 +1,112 @@ +!> \brief \b SET_LAPACK_XERBLA +! +! =========== DOCUMENTATION =========== +! +! Online html documentation available at +! http://www.netlib.org/lapack/explore-html/ +! +! Definition: +! =========== +! +! SUBROUTINE SET_LAPACK_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_LAPACK_XERBLA overrides the LAPACK XERBLA with a replacement subroutine. +!> This can then be negated by calling SET_BLAS_XERBLA with a NULL value, +!> although this is only possible via a C interface as it is forbidden +!> in the Fortran standard. +!> +!> Users should usually also use SET_BLAS_XERBLA since the error +!> handlers may be separate due to the vagaries of linkage. +!> The current handler value can be retrieved by calling GET_LAPACK_XERBLA: +!> +!> PROGRAM HELLO +!> INTERFACE +!> SUBROUTINE XERBLA_INTERFACE(SRNAME, INFO) +!> CHARACTER*(*), INTENT(IN) :: SRNAME +!> INTEGER, INTENT(IN) :: INFO +!> END SUBROUTINE +!> SUBROUTINE GET_LAPACK_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_LAPACK_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_lapack + 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_lapack + +subroutine xerbla_lapack_sub(srname, info) + use xerbla_lapack + character*(*) srname + integer info + if (.not. associated(active_callback)) then + print *, 'Error: LAPACK XERBLA called but no callback registered' + stop 2 + end if + call active_callback(srname, info) +end + +subroutine set_lapack_xerbla(cb) + use xerbla_lapack + 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_lapack_xerbla(cb) + use xerbla_lapack + implicit none + procedure(xerbla_interface), pointer, intent(out) :: cb + cb => active_callback +end diff --git a/TESTING/EIG/cchkdmd.f90 b/TESTING/EIG/cchkdmd.f90 index 79a4a5f6ec..7b63146cb9 100644 --- a/TESTING/EIG/cchkdmd.f90 +++ b/TESTING/EIG/cchkdmd.f90 @@ -84,7 +84,7 @@ PROGRAM DMD_TEST !..... external subroutines (BLAS and LAPACK) EXTERNAL CAXPY, CGEEV, CGEMM, CGEMV, CLASCL, XLAENV, & - CLARNV, CLATMR + CLARNV, CLATMR, SET_LAPACK_XERBLA, XER_REPLACE !.....external subroutines DMD package ! subroutines under test EXTERNAL CGEDMD, CGEDMDQ @@ -103,6 +103,7 @@ PROGRAM DMD_TEST CALL CPU_TIME( S1 ) + CALL SET_LAPACK_XERBLA(XER_REPLACE) WRITE(*,*) 'COMPLEX CODE TESTING' diff --git a/TESTING/EIG/cchkee.F b/TESTING/EIG/cchkee.F index dccc8ac5f3..6953662460 100644 --- a/TESTING/EIG/cchkee.F +++ b/TESTING/EIG/cchkee.F @@ -1113,6 +1113,7 @@ PROGRAM CCHKEE $ CDRVMR3, $ CDRVSX, CDRVVX, CERRBD, CERRED, CERRGG, CERRHS, $ CERRST, ILAVER, XLAENV, CDRGES3, CDRGEV3, + $ SET_LAPACK_XERBLA, XER_REPLACE, $ CCHKST2STG, CDRVST2STG, CCHKHB2STG, CDRVSG2STG * .. * .. Intrinsic Functions .. @@ -1176,6 +1177,7 @@ PROGRAM CCHKEE * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) A = 0.0 B = 0.0 C = 0.0 diff --git a/TESTING/EIG/cerrst.f b/TESTING/EIG/cerrst.f index 83e0679389..656ca583e8 100644 --- a/TESTING/EIG/cerrst.f +++ b/TESTING/EIG/cerrst.f @@ -534,7 +534,7 @@ SUBROUTINE CERRST( PATH, NUNIT ) $ RW, 0, IW, 1, INFO ) CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL CHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, + CALL CHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25000, $ RW, 1, IW, 1, INFO ) CALL CHKXER( 'CHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) * INFOT = 10 diff --git a/TESTING/EIG/dchkdmd.f90 b/TESTING/EIG/dchkdmd.f90 index dbabc7e7a3..b7ba34819c 100644 --- a/TESTING/EIG/dchkdmd.f90 +++ b/TESTING/EIG/dchkdmd.f90 @@ -96,7 +96,7 @@ PROGRAM DMD_TEST LOGICAL TEST_QRDMD !..... external subroutines (BLAS and LAPACK) EXTERNAL DAXPY, DGEEV, DGEMM, DGEMV, DLASCL - EXTERNAL DLARNV, DLATMR, XLAENV + EXTERNAL DLARNV, DLATMR, XLAENV, SET_LAPACK_XERBLA, XER_REPLACE !.....external subroutines DMD package, part 1 ! subroutines under test EXTERNAL DGEDMD, DGEDMDQ @@ -114,6 +114,7 @@ PROGRAM DMD_TEST ! because the test includes comparing the results (in pairs). !..................................................................................... CALL CPU_TIME( S1 ) + CALL SET_LAPACK_XERBLA(XER_REPLACE) TEST_QRDMD = .TRUE. ! This code by default performs tests on DGEDMDQ ! Since the QR factorizations based algorithm is designed for diff --git a/TESTING/EIG/dchkee.F b/TESTING/EIG/dchkee.F index b571fae255..5eb936f788 100644 --- a/TESTING/EIG/dchkee.F +++ b/TESTING/EIG/dchkee.F @@ -1115,6 +1115,7 @@ PROGRAM DCHKEE $ DDRGSX, DDRGVX, DDRVBD, DDRVES, DDRVEV, DDRVST, $ DDRVMR3, $ DDRVSX, DDRVVX, DERRBD, DERRED, DERRGG, DERRHS, + $ SET_LAPACK_XERBLA, XER_REPLACE, $ DERRST, ILAVER, XLAENV, DDRGES3, DDRGEV3, $ DCHKST2STG, DDRVST2STG, DCHKSB2STG, DDRVSG2STG * .. @@ -1169,6 +1170,7 @@ PROGRAM DCHKEE * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) A = 0.0 B = 0.0 C = 0.0 diff --git a/TESTING/EIG/derrst.f b/TESTING/EIG/derrst.f index 3662873a94..d2ac76a014 100644 --- a/TESTING/EIG/derrst.f +++ b/TESTING/EIG/derrst.f @@ -728,7 +728,7 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL DSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO ) CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL DSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, IW, 0, INFO ) + CALL DSYEVD_2STAGE('N', 'U', 2, A, 2, X, W, 25000, IW, 0, INFO) CALL CHKXER( 'DSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) * INFOT = 10 * CALL DSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO ) diff --git a/TESTING/EIG/schkdmd.f90 b/TESTING/EIG/schkdmd.f90 index 2a708dfd88..d79a22cfa6 100644 --- a/TESTING/EIG/schkdmd.f90 +++ b/TESTING/EIG/schkdmd.f90 @@ -96,7 +96,7 @@ PROGRAM DMD_TEST LOGICAL TEST_QRDMD !..... external subroutines (BLAS and LAPACK) EXTERNAL SAXPY, SGEEV, SGEMM, SGEMV, SLASCL - EXTERNAL SLARNV, SLATMR, XLAENV + EXTERNAL SLARNV, SLATMR, XLAENV, SET_LAPACK_XERBLA, XER_REPLACE !.....external subroutines DMD package, part 1 ! subroutines under test EXTERNAL SGEDMD, SGEDMDQ @@ -114,6 +114,7 @@ PROGRAM DMD_TEST ! because the test includes comparing the results (in pairs). !..................................................................................... CALL CPU_TIME( S1 ) + CALL SET_LAPACK_XERBLA(XER_REPLACE) TEST_QRDMD = .TRUE. ! This code by default performs tests on SGEDMDQ ! Since the QR factorizations based algorithm is designed for diff --git a/TESTING/EIG/schkee.F b/TESTING/EIG/schkee.F index d7b1a4f74a..1f6f5658ba 100644 --- a/TESTING/EIG/schkee.F +++ b/TESTING/EIG/schkee.F @@ -1116,6 +1116,7 @@ PROGRAM SCHKEE $ SDRVMR3, $ SDRVSX, SDRVVX, SERRBD, SERRED, SERRGG, SERRHS, $ SERRST, ILAVER, XLAENV, SDRGES3, SDRGEV3, + $ SET_LAPACK_XERBLA, XER_REPLACE, $ SCHKST2STG, SDRVST2STG, SCHKSB2STG, SDRVSG2STG * .. * .. Intrinsic Functions .. @@ -1169,6 +1170,7 @@ PROGRAM SCHKEE * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) A = 0.0 B = 0.0 C = 0.0 diff --git a/TESTING/EIG/serrst.f b/TESTING/EIG/serrst.f index 642a0648cb..f374dfb4ea 100644 --- a/TESTING/EIG/serrst.f +++ b/TESTING/EIG/serrst.f @@ -728,7 +728,7 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL SSYEVD_2STAGE( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO ) CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL SSYEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, IW, 0, INFO ) + CALL SSYEVD_2STAGE('N', 'U', 2, A, 2, X, W, 25000, IW, 0, INFO) CALL CHKXER( 'SSYEVD_2STAGE', INFOT, NOUT, LERR, OK ) * INFOT = 10 * CALL SSYEVD_2STAGE( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO ) diff --git a/TESTING/EIG/xerbla.f b/TESTING/EIG/xerbla.f index 4197f556c0..17cabf6efa 100644 --- a/TESTING/EIG/xerbla.f +++ b/TESTING/EIG/xerbla.f @@ -128,11 +128,3 @@ SUBROUTINE XER_REPLACE( SRNAME, INFO ) * End of XER_REPLACE * END - - SUBROUTINE XERBLA( SRNAME, INFO ) - IMPLICIT NONE - CHARACTER*(*) SRNAME - INTEGER INFO - EXTERNAL XER_REPLACE - CALL XER_REPLACE( SRNAME, INFO ) - END diff --git a/TESTING/EIG/zchkdmd.f90 b/TESTING/EIG/zchkdmd.f90 index ff67175c07..bad7745703 100644 --- a/TESTING/EIG/zchkdmd.f90 +++ b/TESTING/EIG/zchkdmd.f90 @@ -87,7 +87,7 @@ PROGRAM DMD_TEST !.....external subroutines (BLAS and LAPACK) EXTERNAL ZGEEV, ZGEMV, ZLASCL EXTERNAL ZLARNV, ZLATMR, XLAENV - EXTERNAL ZAXPY, ZGEMM + EXTERNAL ZAXPY, ZGEMM, SET_LAPACK_XERBLA, XER_REPLACE !.....external subroutines DMD package, part 1 ! subroutines under test EXTERNAL ZGEDMD, ZGEDMDQ @@ -107,6 +107,7 @@ PROGRAM DMD_TEST ! because the test includes comparing the results (in pairs). !..................................................................................... CALL CPU_TIME( S1 ) + CALL SET_LAPACK_XERBLA(XER_REPLACE) TEST_QRDMD = .TRUE. ! This code by default performs tests on ZGEDMDQ ! Since the QR factorizations based algorithm is designed for diff --git a/TESTING/EIG/zchkee.F b/TESTING/EIG/zchkee.F index 0491f821b2..1c08b84762 100644 --- a/TESTING/EIG/zchkee.F +++ b/TESTING/EIG/zchkee.F @@ -1113,6 +1113,7 @@ PROGRAM ZCHKEE $ ZDRVMR3, $ ZDRVST, ZDRVSX, ZDRVVX, ZERRBD, ZERRED, ZERRGG, $ ZERRHS, ZERRST, ILAVER, ZDRGES3, ZDRGEV3, + $ SET_LAPACK_XERBLA, XER_REPLACE, $ ZCHKST2STG, ZDRVST2STG, ZCHKHB2STG, ZDRVSG2STG * .. * .. Intrinsic Functions .. @@ -1176,6 +1177,7 @@ PROGRAM ZCHKEE * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) A = 0.0 B = 0.0 C = 0.0 diff --git a/TESTING/EIG/zerrst.f b/TESTING/EIG/zerrst.f index ac6b015133..74a8fbaf52 100644 --- a/TESTING/EIG/zerrst.f +++ b/TESTING/EIG/zerrst.f @@ -535,7 +535,7 @@ SUBROUTINE ZERRST( PATH, NUNIT ) $ RW, 0, IW, 1, INFO ) CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) INFOT = 10 - CALL ZHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25, + CALL ZHEEVD_2STAGE( 'N', 'U', 2, A, 2, X, W, 25000, $ RW, 1, IW, 1, INFO ) CALL CHKXER( 'ZHEEVD_2STAGE', INFOT, NOUT, LERR, OK ) * INFOT = 10 diff --git a/TESTING/LIN/cchkaa.F b/TESTING/LIN/cchkaa.F index 5e910c2632..b4baa3d3d4 100644 --- a/TESTING/LIN/cchkaa.F +++ b/TESTING/LIN/cchkaa.F @@ -181,6 +181,7 @@ PROGRAM CCHKAA $ CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, $ CDRVSY, CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, $ ILAVER, CCHKQRT, CCHKQRTP, + $ SET_LAPACK_XERBLA, XER_REPLACE, $ CCHKLQT, CCHKLQTP, CCHKTSQR, $ CCHKHE_AA_2STAGE, CDRVHE_AA_2STAGE, $ CCHKSY_AA_2STAGE, CDRVSY_AA_2STAGE @@ -241,6 +242,7 @@ PROGRAM CCHKAA * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = SECOND( ) LDA = NMAX FATAL = .FALSE. diff --git a/TESTING/LIN/cchkrfp.f b/TESTING/LIN/cchkrfp.f index 5a7a02ade5..b36631998c 100644 --- a/TESTING/LIN/cchkrfp.f +++ b/TESTING/LIN/cchkrfp.f @@ -111,10 +111,25 @@ PROGRAM CCHKRFP * .. * .. External Subroutines .. EXTERNAL ILAVER, CDRVRFP, CDRVRF1, CDRVRF2, CDRVRF3, + + SET_LAPACK_XERBLA, XER_REPLACE, + CDRVRF4, CERRRFP + INTERFACE + SUBROUTINE XERBLA_INTERFACE(SRNAME, INFO) + CHARACTER*(*), INTENT(IN) :: SRNAME + INTEGER, INTENT(IN) :: INFO + END SUBROUTINE + SUBROUTINE GET_LAPACK_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 GET_LAPACK_XERBLA(ALREADY_CB) + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = SECOND( ) FATAL = .FALSE. * diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F index dd5110a820..d608740049 100644 --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -175,6 +175,7 @@ PROGRAM DCHKAA $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, $ DCHKQRT, DCHKQRTP, DCHKLQT, DCHKTSQR, + $ SET_LAPACK_XERBLA, XER_REPLACE, $ DCHKSY_AA_2STAGE, DDRVSY_AA_2STAGE * .. * .. Scalars in Common .. @@ -234,6 +235,7 @@ PROGRAM DCHKAA * * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = DSECND( ) LDA = NMAX FATAL = .FALSE. diff --git a/TESTING/LIN/dchkab.f b/TESTING/LIN/dchkab.f index 3999f211c0..3239696c79 100644 --- a/TESTING/LIN/dchkab.f +++ b/TESTING/LIN/dchkab.f @@ -120,7 +120,7 @@ PROGRAM DCHKAB * .. * .. External Subroutines .. EXTERNAL ALAREQ, DDRVAB, DDRVAC, DERRAB, DERRAC, - $ ILAVER + $ ILAVER, SET_LAPACK_XERBLA, XER_REPLACE * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -136,6 +136,7 @@ PROGRAM DCHKAB * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = DSECND( ) LDA = NMAX FATAL = .FALSE. diff --git a/TESTING/LIN/dchkrfp.f b/TESTING/LIN/dchkrfp.f index 8d265efc1f..541a4ec142 100644 --- a/TESTING/LIN/dchkrfp.f +++ b/TESTING/LIN/dchkrfp.f @@ -110,10 +110,12 @@ PROGRAM DCHKRFP * .. * .. External Subroutines .. EXTERNAL ILAVER, DDRVRFP, DDRVRF1, DDRVRF2, DDRVRF3, + + SET_LAPACK_XERBLA, XER_REPLACE, + DDRVRF4, DERRRFP * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = DSECND( ) FATAL = .FALSE. * diff --git a/TESTING/LIN/schkaa.F b/TESTING/LIN/schkaa.F index 22694325d1..9ea2cadba6 100644 --- a/TESTING/LIN/schkaa.F +++ b/TESTING/LIN/schkaa.F @@ -173,6 +173,7 @@ PROGRAM SCHKAA $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK, $ SDRVSY_RK, SDRVSY_AA, ILAVER, SCHKLQTP, $ SCHKQRT, SCHKQRTP, SCHKLQT, SCHKTSQR, + $ SET_LAPACK_XERBLA, XER_REPLACE, $ SCHKSY_AA_2STAGE, SDRVSY_AA_2STAGE * .. * .. Scalars in Common .. @@ -231,6 +232,7 @@ PROGRAM SCHKAA * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = SECOND( ) LDA = NMAX FATAL = .FALSE. diff --git a/TESTING/LIN/schkrfp.f b/TESTING/LIN/schkrfp.f index d552a65843..8dbbf2e88f 100644 --- a/TESTING/LIN/schkrfp.f +++ b/TESTING/LIN/schkrfp.f @@ -109,10 +109,12 @@ PROGRAM SCHKRFP * .. * .. External Subroutines .. EXTERNAL ILAVER, SDRVRFP, SDRVRF1, SDRVRF2, SDRVRF3, + + SET_LAPACK_XERBLA, XER_REPLACE, + SDRVRF4, SERRRFP * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = SECOND( ) FATAL = .FALSE. * diff --git a/TESTING/LIN/xerbla.f b/TESTING/LIN/xerbla.f index 4b3bd7f997..6ed41c45c1 100644 --- a/TESTING/LIN/xerbla.f +++ b/TESTING/LIN/xerbla.f @@ -128,11 +128,3 @@ SUBROUTINE XER_REPLACE( SRNAME, INFO ) * End of XER_REPLACE * END - - SUBROUTINE XERBLA( SRNAME, INFO ) - IMPLICIT NONE - CHARACTER*(*) SRNAME - INTEGER INFO - EXTERNAL XER_REPLACE - CALL XER_REPLACE( SRNAME, INFO ) - END diff --git a/TESTING/LIN/zchkaa.F b/TESTING/LIN/zchkaa.F index 50ab1103f7..7b3addd29f 100644 --- a/TESTING/LIN/zchkaa.F +++ b/TESTING/LIN/zchkaa.F @@ -183,6 +183,7 @@ PROGRAM ZCHKAA $ ZDRVSY_ROOK, ZDRVSY_RK, ZDRVSY_AA, $ ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, ZCHKQRTP, $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR, + $ SET_LAPACK_XERBLA, XER_REPLACE, $ ZCHKHE_AA_2STAGE, ZCHKSY_AA_2STAGE * .. * .. Scalars in Common .. @@ -241,6 +242,7 @@ PROGRAM ZCHKAA * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = DSECND( ) LDA = NMAX FATAL = .FALSE. diff --git a/TESTING/LIN/zchkab.f b/TESTING/LIN/zchkab.f index 2f2c92c564..84affb1ed6 100644 --- a/TESTING/LIN/zchkab.f +++ b/TESTING/LIN/zchkab.f @@ -121,7 +121,7 @@ PROGRAM ZCHKAB * .. * .. External Subroutines .. EXTERNAL ALAREQ, ZDRVAB, ZDRVAC, ZERRAB, ZERRAC, - $ ILAVER + $ ILAVER, SET_LAPACK_XERBLA, XER_REPLACE * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -137,6 +137,7 @@ PROGRAM ZCHKAB * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = DSECND( ) LDA = NMAX FATAL = .FALSE. diff --git a/TESTING/LIN/zchkrfp.f b/TESTING/LIN/zchkrfp.f index bff2192ab2..0d6c984595 100644 --- a/TESTING/LIN/zchkrfp.f +++ b/TESTING/LIN/zchkrfp.f @@ -111,10 +111,12 @@ PROGRAM ZCHKRFP * .. * .. External Subroutines .. EXTERNAL ILAVER, ZDRVRFP, ZDRVRF1, ZDRVRF2, ZDRVRF3, + + SET_LAPACK_XERBLA, XER_REPLACE, + ZDRVRF4, ZERRRFP * .. * .. Executable Statements .. * + CALL SET_LAPACK_XERBLA(XER_REPLACE) S1 = DSECND( ) FATAL = .FALSE. *