You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
222 lines
6.4 KiB
222 lines
6.4 KiB
2 years ago
|
*> \brief \b SLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.
|
||
|
|
*
|
||
|
|
* =========== DOCUMENTATION ===========
|
||
|
|
*
|
||
|
|
* Online html documentation available at
|
||
|
|
* http://www.netlib.org/lapack/explore-html/
|
||
|
|
*
|
||
|
|
*> \htmlonly
|
||
|
|
*> Download SLASQ1 + dependencies
|
||
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasq1.f">
|
||
|
|
*> [TGZ]</a>
|
||
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasq1.f">
|
||
|
|
*> [ZIP]</a>
|
||
|
|
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasq1.f">
|
||
|
|
*> [TXT]</a>
|
||
|
|
*> \endhtmlonly
|
||
|
|
*
|
||
|
|
* Definition:
|
||
|
|
* ===========
|
||
|
|
*
|
||
|
|
* SUBROUTINE SLASQ1( N, D, E, WORK, INFO )
|
||
|
|
*
|
||
|
|
* .. Scalar Arguments ..
|
||
|
|
* INTEGER INFO, N
|
||
|
|
* ..
|
||
|
|
* .. Array Arguments ..
|
||
|
|
* REAL D( * ), E( * ), WORK( * )
|
||
|
|
* ..
|
||
|
|
*
|
||
|
|
*
|
||
|
|
*> \par Purpose:
|
||
|
|
* =============
|
||
|
|
*>
|
||
|
|
*> \verbatim
|
||
|
|
*>
|
||
|
|
*> SLASQ1 computes the singular values of a real N-by-N bidiagonal
|
||
|
|
*> matrix with diagonal D and off-diagonal E. The singular values
|
||
|
|
*> are computed to high relative accuracy, in the absence of
|
||
|
|
*> denormalization, underflow and overflow. The algorithm was first
|
||
|
|
*> presented in
|
||
|
|
*>
|
||
|
|
*> "Accurate singular values and differential qd algorithms" by K. V.
|
||
|
|
*> Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
|
||
|
|
*> 1994,
|
||
|
|
*>
|
||
|
|
*> and the present implementation is described in "An implementation of
|
||
|
|
*> the dqds Algorithm (Positive Case)", LAPACK Working Note.
|
||
|
|
*> \endverbatim
|
||
|
|
*
|
||
|
|
* Arguments:
|
||
|
|
* ==========
|
||
|
|
*
|
||
|
|
*> \param[in] N
|
||
|
|
*> \verbatim
|
||
|
|
*> N is INTEGER
|
||
|
|
*> The number of rows and columns in the matrix. N >= 0.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[in,out] D
|
||
|
|
*> \verbatim
|
||
|
|
*> D is REAL array, dimension (N)
|
||
|
|
*> On entry, D contains the diagonal elements of the
|
||
|
|
*> bidiagonal matrix whose SVD is desired. On normal exit,
|
||
|
|
*> D contains the singular values in decreasing order.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[in,out] E
|
||
|
|
*> \verbatim
|
||
|
|
*> E is REAL array, dimension (N)
|
||
|
|
*> On entry, elements E(1:N-1) contain the off-diagonal elements
|
||
|
|
*> of the bidiagonal matrix whose SVD is desired.
|
||
|
|
*> On exit, E is overwritten.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] WORK
|
||
|
|
*> \verbatim
|
||
|
|
*> WORK is REAL array, dimension (4*N)
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[out] INFO
|
||
|
|
*> \verbatim
|
||
|
|
*> INFO is INTEGER
|
||
|
|
*> = 0: successful exit
|
||
|
|
*> < 0: if INFO = -i, the i-th argument had an illegal value
|
||
|
|
*> > 0: the algorithm failed
|
||
|
|
*> = 1, a split was marked by a positive value in E
|
||
|
|
*> = 2, current block of Z not diagonalized after 100*N
|
||
|
|
*> iterations (in inner while loop) On exit D and E
|
||
|
|
*> represent a matrix with the same singular values
|
||
|
|
*> which the calling subroutine could use to finish the
|
||
|
|
*> computation, or even feed back into SLASQ1
|
||
|
|
*> = 3, termination criterion of outer while loop not met
|
||
|
|
*> (program created more than N unreduced blocks)
|
||
|
|
*> \endverbatim
|
||
|
|
*
|
||
|
|
* Authors:
|
||
|
|
* ========
|
||
|
|
*
|
||
|
|
*> \author Univ. of Tennessee
|
||
|
|
*> \author Univ. of California Berkeley
|
||
|
|
*> \author Univ. of Colorado Denver
|
||
|
|
*> \author NAG Ltd.
|
||
|
|
*
|
||
|
|
*> \ingroup auxOTHERcomputational
|
||
|
|
*
|
||
|
|
* =====================================================================
|
||
|
|
SUBROUTINE SLASQ1( N, D, E, WORK, INFO )
|
||
|
|
*
|
||
|
|
* -- LAPACK computational routine --
|
||
|
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||
|
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||
|
|
*
|
||
|
|
* .. Scalar Arguments ..
|
||
|
|
INTEGER INFO, N
|
||
|
|
* ..
|
||
|
|
* .. Array Arguments ..
|
||
|
|
REAL D( * ), E( * ), WORK( * )
|
||
|
|
* ..
|
||
|
|
*
|
||
|
|
* =====================================================================
|
||
|
|
*
|
||
|
|
* .. Parameters ..
|
||
|
|
REAL ZERO
|
||
|
|
PARAMETER ( ZERO = 0.0E0 )
|
||
|
|
* ..
|
||
|
|
* .. Local Scalars ..
|
||
|
|
INTEGER I, IINFO
|
||
|
|
REAL EPS, SCALE, SAFMIN, SIGMN, SIGMX
|
||
|
|
* ..
|
||
|
|
* .. External Subroutines ..
|
||
|
|
EXTERNAL SCOPY, SLAS2, SLASCL, SLASQ2, SLASRT, XERBLA
|
||
|
|
* ..
|
||
|
|
* .. External Functions ..
|
||
|
|
REAL SLAMCH
|
||
|
|
EXTERNAL SLAMCH
|
||
|
|
* ..
|
||
|
|
* .. Intrinsic Functions ..
|
||
|
|
INTRINSIC ABS, MAX, SQRT
|
||
|
|
* ..
|
||
|
|
* .. Executable Statements ..
|
||
|
|
*
|
||
|
|
INFO = 0
|
||
|
|
IF( N.LT.0 ) THEN
|
||
|
|
INFO = -1
|
||
|
|
CALL XERBLA( 'SLASQ1', -INFO )
|
||
|
|
RETURN
|
||
|
|
ELSE IF( N.EQ.0 ) THEN
|
||
|
|
RETURN
|
||
|
|
ELSE IF( N.EQ.1 ) THEN
|
||
|
|
D( 1 ) = ABS( D( 1 ) )
|
||
|
|
RETURN
|
||
|
|
ELSE IF( N.EQ.2 ) THEN
|
||
|
|
CALL SLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
|
||
|
|
D( 1 ) = SIGMX
|
||
|
|
D( 2 ) = SIGMN
|
||
|
|
RETURN
|
||
|
|
END IF
|
||
|
|
*
|
||
|
|
* Estimate the largest singular value.
|
||
|
|
*
|
||
|
|
SIGMX = ZERO
|
||
|
|
DO 10 I = 1, N - 1
|
||
|
|
D( I ) = ABS( D( I ) )
|
||
|
|
SIGMX = MAX( SIGMX, ABS( E( I ) ) )
|
||
|
|
10 CONTINUE
|
||
|
|
D( N ) = ABS( D( N ) )
|
||
|
|
*
|
||
|
|
* Early return if SIGMX is zero (matrix is already diagonal).
|
||
|
|
*
|
||
|
|
IF( SIGMX.EQ.ZERO ) THEN
|
||
|
|
CALL SLASRT( 'D', N, D, IINFO )
|
||
|
|
RETURN
|
||
|
|
END IF
|
||
|
|
*
|
||
|
|
DO 20 I = 1, N
|
||
|
|
SIGMX = MAX( SIGMX, D( I ) )
|
||
|
|
20 CONTINUE
|
||
|
|
*
|
||
|
|
* Copy D and E into WORK (in the Z format) and scale (squaring the
|
||
|
|
* input data makes scaling by a power of the radix pointless).
|
||
|
|
*
|
||
|
|
EPS = SLAMCH( 'Precision' )
|
||
|
|
SAFMIN = SLAMCH( 'Safe minimum' )
|
||
|
|
SCALE = SQRT( EPS / SAFMIN )
|
||
|
|
CALL SCOPY( N, D, 1, WORK( 1 ), 2 )
|
||
|
|
CALL SCOPY( N-1, E, 1, WORK( 2 ), 2 )
|
||
|
|
CALL SLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
|
||
|
|
$ IINFO )
|
||
|
|
*
|
||
|
|
* Compute the q's and e's.
|
||
|
|
*
|
||
|
|
DO 30 I = 1, 2*N - 1
|
||
|
|
WORK( I ) = WORK( I )**2
|
||
|
|
30 CONTINUE
|
||
|
|
WORK( 2*N ) = ZERO
|
||
|
|
*
|
||
|
|
CALL SLASQ2( N, WORK, INFO )
|
||
|
|
*
|
||
|
|
IF( INFO.EQ.0 ) THEN
|
||
|
|
DO 40 I = 1, N
|
||
|
|
D( I ) = SQRT( WORK( I ) )
|
||
|
|
40 CONTINUE
|
||
|
|
CALL SLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
|
||
|
|
ELSE IF( INFO.EQ.2 ) THEN
|
||
|
|
*
|
||
|
|
* Maximum number of iterations exceeded. Move data from WORK
|
||
|
|
* into D and E so the calling subroutine can try to finish
|
||
|
|
*
|
||
|
|
DO I = 1, N
|
||
|
|
D( I ) = SQRT( WORK( 2*I-1 ) )
|
||
|
|
E( I ) = SQRT( WORK( 2*I ) )
|
||
|
|
END DO
|
||
|
|
CALL SLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
|
||
|
|
CALL SLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, E, N, IINFO )
|
||
|
|
END IF
|
||
|
|
*
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* End of SLASQ1
|
||
|
|
*
|
||
|
|
END
|