From ea007b5c03db4dded7ccb111e83fa73516ec6a18 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Wed, 24 Jun 2026 16:50:13 +0200 Subject: [PATCH] Increase deflation tolerance to match ?LASD7 (Reference-LAPACK PR 1286) --- lapack-netlib/SRC/dlasd2.f | 19 +++++++++++-------- lapack-netlib/SRC/slasd2.f | 19 +++++++++++-------- 2 files changed, 22 insertions(+), 16 deletions(-) diff --git a/lapack-netlib/SRC/dlasd2.f b/lapack-netlib/SRC/dlasd2.f index 33724164f3..edcd381cc4 100644 --- a/lapack-netlib/SRC/dlasd2.f +++ b/lapack-netlib/SRC/dlasd2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DLASD2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -254,7 +252,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup OTHERauxiliary +*> \ingroup lasd2 * *> \par Contributors: * ================== @@ -263,9 +261,11 @@ *> California at Berkeley, USA *> * ===================================================================== - SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, + SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, + $ VT, $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, $ IDXC, IDXQ, COLTYP, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -303,7 +303,8 @@ SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, EXTERNAL DLAMCH, DLAPY2 * .. * .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA + EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, + $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX @@ -396,7 +397,7 @@ SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, * EPS = DLAMCH( 'Epsilon' ) TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) - TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) + TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) * * There are 2 kinds of deflation -- first a value in the z-vector * is small, second two (or more) singular values are very close @@ -479,7 +480,8 @@ SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, IDXJ = IDXJ - 1 END IF CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S ) - CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C, + CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, + $ C, $ S ) IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN COLTYP( J ) = 3 @@ -621,7 +623,8 @@ SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ), $ LDU ) - CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ), + CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, + $ 1 ), $ LDVT ) END IF * diff --git a/lapack-netlib/SRC/slasd2.f b/lapack-netlib/SRC/slasd2.f index d6cd24c1f3..07e65c82e6 100644 --- a/lapack-netlib/SRC/slasd2.f +++ b/lapack-netlib/SRC/slasd2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SLASD2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -254,7 +252,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup OTHERauxiliary +*> \ingroup lasd2 * *> \par Contributors: * ================== @@ -263,9 +261,11 @@ *> California at Berkeley, USA *> * ===================================================================== - SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, + SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, + $ VT, $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, $ IDXC, IDXQ, COLTYP, INFO ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -303,7 +303,8 @@ SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, EXTERNAL SLAMCH, SLAPY2 * .. * .. External Subroutines .. - EXTERNAL SCOPY, SLACPY, SLAMRG, SLASET, SROT, XERBLA + EXTERNAL SCOPY, SLACPY, SLAMRG, SLASET, SROT, + $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX @@ -396,7 +397,7 @@ SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, * EPS = SLAMCH( 'Epsilon' ) TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) - TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) + TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) * * There are 2 kinds of deflation -- first a value in the z-vector * is small, second two (or more) singular values are very close @@ -479,7 +480,8 @@ SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, IDXJ = IDXJ - 1 END IF CALL SROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S ) - CALL SROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C, + CALL SROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, + $ C, $ S ) IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN COLTYP( J ) = 3 @@ -621,7 +623,8 @@ SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) CALL SLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ), $ LDU ) - CALL SLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ), + CALL SLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, + $ 1 ), $ LDVT ) END IF *