From 993978c7843c36f07f47a9b93d0534978aa3c973 Mon Sep 17 00:00:00 2001 From: Rio Yu <52408936+rioyu123@users.noreply.github.com> Date: Sat, 3 Oct 2026 10:09:52 +0800 Subject: [PATCH 1/2] Fix zero-pivot columns in blocked symmetric factorizations --- SRC/clahef.f | 2 ++ SRC/clasyf.f | 2 ++ SRC/dlasyf.f | 2 ++ SRC/slasyf.f | 2 ++ SRC/zlahef.f | 2 ++ SRC/zlasyf.f | 2 ++ TESTING/LIN/cchkhe.f | 64 +++++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/cchksy.f | 65 ++++++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/dchksy.f | 59 ++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/schksy.f | 59 ++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/zchkhe.f | 64 +++++++++++++++++++++++++++++++++++++++++++ TESTING/LIN/zchksy.f | 65 ++++++++++++++++++++++++++++++++++++++++++++ 12 files changed, 388 insertions(+) diff --git a/SRC/clahef.f b/SRC/clahef.f index 21c9f0986e..6d77b01ded 100644 --- a/SRC/clahef.f +++ b/SRC/clahef.f @@ -286,6 +286,7 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) A( K, K ) = REAL( A( K, K ) ) ELSE * @@ -637,6 +638,7 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) A( K, K ) = REAL( A( K, K ) ) ELSE * diff --git a/SRC/clasyf.f b/SRC/clasyf.f index 926c62de68..2caab31bbd 100644 --- a/SRC/clasyf.f +++ b/SRC/clasyf.f @@ -281,6 +281,7 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -562,6 +563,7 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * diff --git a/SRC/dlasyf.f b/SRC/dlasyf.f index 68e0087f38..c3000a2f28 100644 --- a/SRC/dlasyf.f +++ b/SRC/dlasyf.f @@ -272,6 +272,7 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -554,6 +555,7 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * diff --git a/SRC/slasyf.f b/SRC/slasyf.f index 129607a2bd..8d77de927d 100644 --- a/SRC/slasyf.f +++ b/SRC/slasyf.f @@ -272,6 +272,7 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -554,6 +555,7 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * diff --git a/SRC/zlahef.f b/SRC/zlahef.f index 039444a0da..2ca1735f49 100644 --- a/SRC/zlahef.f +++ b/SRC/zlahef.f @@ -285,6 +285,7 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) A( K, K ) = DBLE( A( K, K ) ) ELSE * @@ -636,6 +637,7 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) A( K, K ) = DBLE( A( K, K ) ) ELSE * diff --git a/SRC/zlasyf.f b/SRC/zlasyf.f index 5363c390e6..599f6f7f77 100644 --- a/SRC/zlasyf.f +++ b/SRC/zlasyf.f @@ -280,6 +280,7 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * @@ -560,6 +561,7 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, IF( INFO.EQ.0 ) $ INFO = K KP = K + CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * diff --git a/TESTING/LIN/cchkhe.f b/TESTING/LIN/cchkhe.f index 7797e14b46..f2110d3763 100644 --- a/TESTING/LIN/cchkhe.f +++ b/TESTING/LIN/cchkhe.f @@ -663,10 +663,74 @@ SUBROUTINE CCHKHE( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 CONTINUE 180 CONTINUE * +* +* Check an exact zero pivot created by updating a rank-one block +* when the singular matrix tests are requested. +* Unlike a row that is zero on input, its original diagonal must +* be replaced by the updated zero before returning the factors. +* + IF( .NOT.DOTYPE( 3 ) ) GO TO 260 + DO 250 IN = 1, NN + N = NVAL( IN ) + IF( N.LT.3 ) GO TO 250 + LDA = N + DO 240 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) + I1 = 1 + IF( IUPLO.EQ.1 ) I1 = N - 1 + I2 = I1 + 1 + IZERO = I2 + IF( IUPLO.EQ.1 ) IZERO = I1 + DO 230 MODE = 1, 2 + DO 200 J = 1, N + DO 190 I = 1, N + A( I+( J-1 )*LDA ) = ZERO + 190 CONTINUE + A( J+( J-1 )*LDA ) = 1.0E+0 + 200 CONTINUE + A( I1+( I1-1 )*LDA ) = 0.0625E+0 + A( I2+( I2-1 )*LDA ) = 0.0625E+0 + A( I1+( I2-1 )*LDA ) = 0.0625E+0 + A( I2+( I1-1 )*LDA ) = 0.0625E+0 + IF( MODE.EQ.2 ) THEN + A( I1+( I2-1 )*LDA ) = ( 0.0E+0, 0.0625E+0 ) + A( I2+( I1-1 )*LDA ) = - + $ A( I1+( I2-1 )*LDA ) + END IF + DO 220 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'CHETRF' + CALL CHETRF( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) + IF( INFO.NE.IZERO ) + $ CALL ALAERH( PATH, 'CHETRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, 3, NFAIL, + $ NERRS, NOUT ) + CALL CHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + IF( RESULT( 1 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )UPLO, N, NB, MODE, + $ RESULT( 1 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * + 9996 FORMAT( ' Zero pivot: UPLO = ''', A1, ''', N =', I5, + $ ', NB =', I4, ', mode =', I2, ', ratio =', G12.5 ) 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', $ I2, ', test ', I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', diff --git a/TESTING/LIN/cchksy.f b/TESTING/LIN/cchksy.f index f33cb879f2..d144e33c76 100644 --- a/TESTING/LIN/cchksy.f +++ b/TESTING/LIN/cchksy.f @@ -670,10 +670,75 @@ SUBROUTINE CCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 CONTINUE 180 CONTINUE * +* +* Check an exact zero pivot created by updating a rank-one block +* when the singular matrix tests are requested. +* Unlike a row that is zero on input, its original diagonal must +* be replaced by the updated zero before returning the factors. +* + IF( .NOT.DOTYPE( 3 ) ) GO TO 260 + DO 250 IN = 1, NN + N = NVAL( IN ) + IF( N.LT.3 ) GO TO 250 + LDA = N + DO 240 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) + I1 = 1 + IF( IUPLO.EQ.1 ) I1 = N - 1 + I2 = I1 + 1 + IZERO = I2 + IF( IUPLO.EQ.1 ) IZERO = I1 + DO 230 MODE = 1, 2 + DO 200 J = 1, N + DO 190 I = 1, N + A( I+( J-1 )*LDA ) = ZERO + 190 CONTINUE + A( J+( J-1 )*LDA ) = 1.0E+0 + 200 CONTINUE + A( I1+( I1-1 )*LDA ) = 0.0625E+0 + A( I2+( I2-1 )*LDA ) = 0.0625E+0 + A( I1+( I2-1 )*LDA ) = 0.0625E+0 + A( I2+( I1-1 )*LDA ) = 0.0625E+0 + IF( MODE.EQ.2 ) THEN + A( I1+( I2-1 )*LDA ) = ( 0.0E+0, 0.0625E+0 ) + A( I2+( I1-1 )*LDA ) = + $ A( I1+( I2-1 )*LDA ) + A( I2+( I2-1 )*LDA ) = -0.0625E+0 + END IF + DO 220 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'CSYTRF' + CALL CSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) + IF( INFO.NE.IZERO ) + $ CALL ALAERH( PATH, 'CSYTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, 3, NFAIL, + $ NERRS, NOUT ) + CALL CSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + IF( RESULT( 1 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )UPLO, N, NB, MODE, + $ RESULT( 1 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * + 9996 FORMAT( ' Zero pivot: UPLO = ''', A1, ''', N =', I5, + $ ', NB =', I4, ', mode =', I2, ', ratio =', G12.5 ) 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', $ I2, ', test ', I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', diff --git a/TESTING/LIN/dchksy.f b/TESTING/LIN/dchksy.f index 4d9789e742..178eec06c8 100644 --- a/TESTING/LIN/dchksy.f +++ b/TESTING/LIN/dchksy.f @@ -656,10 +656,69 @@ SUBROUTINE DCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 CONTINUE 180 CONTINUE * +* +* Check an exact zero pivot created by updating a rank-one block +* when the singular matrix tests are requested. +* Unlike a row that is zero on input, its original diagonal must +* be replaced by the updated zero before returning the factors. +* + IF( .NOT.DOTYPE( 3 ) ) GO TO 260 + DO 250 IN = 1, NN + N = NVAL( IN ) + IF( N.LT.3 ) GO TO 250 + LDA = N + DO 240 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) + I1 = 1 + IF( IUPLO.EQ.1 ) I1 = N - 1 + I2 = I1 + 1 + IZERO = I2 + IF( IUPLO.EQ.1 ) IZERO = I1 + DO 230 MODE = 1, 1 + DO 200 J = 1, N + DO 190 I = 1, N + A( I+( J-1 )*LDA ) = ZERO + 190 CONTINUE + A( J+( J-1 )*LDA ) = 1.0D+0 + 200 CONTINUE + A( I1+( I1-1 )*LDA ) = 0.0625D+0 + A( I2+( I2-1 )*LDA ) = 0.0625D+0 + A( I1+( I2-1 )*LDA ) = 0.0625D+0 + A( I2+( I1-1 )*LDA ) = 0.0625D+0 + DO 220 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'DSYTRF' + CALL DSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) + IF( INFO.NE.IZERO ) + $ CALL ALAERH( PATH, 'DSYTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, 3, NFAIL, + $ NERRS, NOUT ) + CALL DSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + IF( RESULT( 1 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )UPLO, N, NB, MODE, + $ RESULT( 1 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * + 9996 FORMAT( ' Zero pivot: UPLO = ''', A1, ''', N =', I5, + $ ', NB =', I4, ', mode =', I2, ', ratio =', G12.5 ) 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', $ I2, ', test ', I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', diff --git a/TESTING/LIN/schksy.f b/TESTING/LIN/schksy.f index a8de72ca6b..9b43398f53 100644 --- a/TESTING/LIN/schksy.f +++ b/TESTING/LIN/schksy.f @@ -655,10 +655,69 @@ SUBROUTINE SCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 CONTINUE 180 CONTINUE * +* +* Check an exact zero pivot created by updating a rank-one block +* when the singular matrix tests are requested. +* Unlike a row that is zero on input, its original diagonal must +* be replaced by the updated zero before returning the factors. +* + IF( .NOT.DOTYPE( 3 ) ) GO TO 260 + DO 250 IN = 1, NN + N = NVAL( IN ) + IF( N.LT.3 ) GO TO 250 + LDA = N + DO 240 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) + I1 = 1 + IF( IUPLO.EQ.1 ) I1 = N - 1 + I2 = I1 + 1 + IZERO = I2 + IF( IUPLO.EQ.1 ) IZERO = I1 + DO 230 MODE = 1, 1 + DO 200 J = 1, N + DO 190 I = 1, N + A( I+( J-1 )*LDA ) = ZERO + 190 CONTINUE + A( J+( J-1 )*LDA ) = 1.0E+0 + 200 CONTINUE + A( I1+( I1-1 )*LDA ) = 0.0625E+0 + A( I2+( I2-1 )*LDA ) = 0.0625E+0 + A( I1+( I2-1 )*LDA ) = 0.0625E+0 + A( I2+( I1-1 )*LDA ) = 0.0625E+0 + DO 220 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'SSYTRF' + CALL SSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) + IF( INFO.NE.IZERO ) + $ CALL ALAERH( PATH, 'SSYTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, 3, NFAIL, + $ NERRS, NOUT ) + CALL SSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + IF( RESULT( 1 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )UPLO, N, NB, MODE, + $ RESULT( 1 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * + 9996 FORMAT( ' Zero pivot: UPLO = ''', A1, ''', N =', I5, + $ ', NB =', I4, ', mode =', I2, ', ratio =', G12.5 ) 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', $ I2, ', test ', I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', diff --git a/TESTING/LIN/zchkhe.f b/TESTING/LIN/zchkhe.f index 0f6dc3f06c..e4f6790240 100644 --- a/TESTING/LIN/zchkhe.f +++ b/TESTING/LIN/zchkhe.f @@ -651,10 +651,74 @@ SUBROUTINE ZCHKHE( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 CONTINUE 180 CONTINUE * +* +* Check an exact zero pivot created by updating a rank-one block +* when the singular matrix tests are requested. +* Unlike a row that is zero on input, its original diagonal must +* be replaced by the updated zero before returning the factors. +* + IF( .NOT.DOTYPE( 3 ) ) GO TO 260 + DO 250 IN = 1, NN + N = NVAL( IN ) + IF( N.LT.3 ) GO TO 250 + LDA = N + DO 240 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) + I1 = 1 + IF( IUPLO.EQ.1 ) I1 = N - 1 + I2 = I1 + 1 + IZERO = I2 + IF( IUPLO.EQ.1 ) IZERO = I1 + DO 230 MODE = 1, 2 + DO 200 J = 1, N + DO 190 I = 1, N + A( I+( J-1 )*LDA ) = ZERO + 190 CONTINUE + A( J+( J-1 )*LDA ) = 1.0D+0 + 200 CONTINUE + A( I1+( I1-1 )*LDA ) = 0.0625D+0 + A( I2+( I2-1 )*LDA ) = 0.0625D+0 + A( I1+( I2-1 )*LDA ) = 0.0625D+0 + A( I2+( I1-1 )*LDA ) = 0.0625D+0 + IF( MODE.EQ.2 ) THEN + A( I1+( I2-1 )*LDA ) = ( 0.0D+0, 0.0625D+0 ) + A( I2+( I1-1 )*LDA ) = - + $ A( I1+( I2-1 )*LDA ) + END IF + DO 220 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'ZHETRF' + CALL ZHETRF( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) + IF( INFO.NE.IZERO ) + $ CALL ALAERH( PATH, 'ZHETRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, 3, NFAIL, + $ NERRS, NOUT ) + CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + IF( RESULT( 1 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )UPLO, N, NB, MODE, + $ RESULT( 1 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * + 9996 FORMAT( ' Zero pivot: UPLO = ''', A1, ''', N =', I5, + $ ', NB =', I4, ', mode =', I2, ', ratio =', G12.5 ) 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', $ I2, ', test ', I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', diff --git a/TESTING/LIN/zchksy.f b/TESTING/LIN/zchksy.f index 0c8c2c2b16..f5394a68ad 100644 --- a/TESTING/LIN/zchksy.f +++ b/TESTING/LIN/zchksy.f @@ -671,10 +671,75 @@ SUBROUTINE ZCHKSY( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 CONTINUE 180 CONTINUE * +* +* Check an exact zero pivot created by updating a rank-one block +* when the singular matrix tests are requested. +* Unlike a row that is zero on input, its original diagonal must +* be replaced by the updated zero before returning the factors. +* + IF( .NOT.DOTYPE( 3 ) ) GO TO 260 + DO 250 IN = 1, NN + N = NVAL( IN ) + IF( N.LT.3 ) GO TO 250 + LDA = N + DO 240 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) + I1 = 1 + IF( IUPLO.EQ.1 ) I1 = N - 1 + I2 = I1 + 1 + IZERO = I2 + IF( IUPLO.EQ.1 ) IZERO = I1 + DO 230 MODE = 1, 2 + DO 200 J = 1, N + DO 190 I = 1, N + A( I+( J-1 )*LDA ) = ZERO + 190 CONTINUE + A( J+( J-1 )*LDA ) = 1.0D+0 + 200 CONTINUE + A( I1+( I1-1 )*LDA ) = 0.0625D+0 + A( I2+( I2-1 )*LDA ) = 0.0625D+0 + A( I1+( I2-1 )*LDA ) = 0.0625D+0 + A( I2+( I1-1 )*LDA ) = 0.0625D+0 + IF( MODE.EQ.2 ) THEN + A( I1+( I2-1 )*LDA ) = ( 0.0D+0, 0.0625D+0 ) + A( I2+( I1-1 )*LDA ) = + $ A( I1+( I2-1 )*LDA ) + A( I2+( I2-1 )*LDA ) = -0.0625D+0 + END IF + DO 220 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'ZSYTRF' + CALL ZSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, + $ LWORK, INFO ) + IF( INFO.NE.IZERO ) + $ CALL ALAERH( PATH, 'ZSYTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, 3, NFAIL, + $ NERRS, NOUT ) + CALL ZSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + IF( RESULT( 1 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9996 )UPLO, N, NB, MODE, + $ RESULT( 1 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE +* * Print a summary of the results. * CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * + 9996 FORMAT( ' Zero pivot: UPLO = ''', A1, ''', N =', I5, + $ ', NB =', I4, ', mode =', I2, ', ratio =', G12.5 ) 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', $ I2, ', test ', I2, ', ratio =', G12.5 ) 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', From 5b14af5851a55436b317cfed81ca09077e414b98 Mon Sep 17 00:00:00 2001 From: Rio Yu <52408936+rioyu123@users.noreply.github.com> Date: Sun, 4 Oct 2026 16:32:37 +0800 Subject: [PATCH 2/2] Remove redundant real-diagonal assignments after panel copies --- SRC/clahef.f | 2 -- SRC/zlahef.f | 2 -- 2 files changed, 4 deletions(-) diff --git a/SRC/clahef.f b/SRC/clahef.f index 6d77b01ded..44d4c17d03 100644 --- a/SRC/clahef.f +++ b/SRC/clahef.f @@ -287,7 +287,6 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, $ INFO = K KP = K CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) - A( K, K ) = REAL( A( K, K ) ) ELSE * * ============================================================ @@ -639,7 +638,6 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, $ INFO = K KP = K CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) - A( K, K ) = REAL( A( K, K ) ) ELSE * * ============================================================ diff --git a/SRC/zlahef.f b/SRC/zlahef.f index 2ca1735f49..1ccf37566b 100644 --- a/SRC/zlahef.f +++ b/SRC/zlahef.f @@ -286,7 +286,6 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, $ INFO = K KP = K CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) - A( K, K ) = DBLE( A( K, K ) ) ELSE * * ============================================================ @@ -638,7 +637,6 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, $ INFO = K KP = K CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) - A( K, K ) = DBLE( A( K, K ) ) ELSE * * ============================================================