Refs #247. Included lapack source codes. Avoid downloading tar.gz from netlib.org
Based on 3.4.2 version, apply patch.for_lapack-3.4.2.
This commit is contained in:
Zhang Xianyi
323
lapack-netlib/SRC/slasd1.f
Normal file
323
lapack-netlib/SRC/slasd1.f
Normal file
@@ -0,0 +1,323 @@
|
||||
*> \brief \b SLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc.
|
||||
*
|
||||
* =========== DOCUMENTATION ===========
|
||||
*
|
||||
* Online html documentation available at
|
||||
* http://www.netlib.org/lapack/explore-html/
|
||||
*
|
||||
*> \htmlonly
|
||||
*> Download SLASD1 + dependencies
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasd1.f">
|
||||
*> [TGZ]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasd1.f">
|
||||
*> [ZIP]</a>
|
||||
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasd1.f">
|
||||
*> [TXT]</a>
|
||||
*> \endhtmlonly
|
||||
*
|
||||
* Definition:
|
||||
* ===========
|
||||
*
|
||||
* SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
|
||||
* IDXQ, IWORK, WORK, INFO )
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
* INTEGER INFO, LDU, LDVT, NL, NR, SQRE
|
||||
* REAL ALPHA, BETA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
* INTEGER IDXQ( * ), IWORK( * )
|
||||
* REAL D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
*
|
||||
*> \par Purpose:
|
||||
* =============
|
||||
*>
|
||||
*> \verbatim
|
||||
*>
|
||||
*> SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
|
||||
*> where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.
|
||||
*>
|
||||
*> A related subroutine SLASD7 handles the case in which the singular
|
||||
*> values (and the singular vectors in factored form) are desired.
|
||||
*>
|
||||
*> SLASD1 computes the SVD as follows:
|
||||
*>
|
||||
*> ( D1(in) 0 0 0 )
|
||||
*> B = U(in) * ( Z1**T a Z2**T b ) * VT(in)
|
||||
*> ( 0 0 D2(in) 0 )
|
||||
*>
|
||||
*> = U(out) * ( D(out) 0) * VT(out)
|
||||
*>
|
||||
*> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M
|
||||
*> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
|
||||
*> elsewhere; and the entry b is empty if SQRE = 0.
|
||||
*>
|
||||
*> The left singular vectors of the original matrix are stored in U, and
|
||||
*> the transpose of the right singular vectors are stored in VT, and the
|
||||
*> singular values are in D. The algorithm consists of three stages:
|
||||
*>
|
||||
*> The first stage consists of deflating the size of the problem
|
||||
*> when there are multiple singular values or when there are zeros in
|
||||
*> the Z vector. For each such occurence the dimension of the
|
||||
*> secular equation problem is reduced by one. This stage is
|
||||
*> performed by the routine SLASD2.
|
||||
*>
|
||||
*> The second stage consists of calculating the updated
|
||||
*> singular values. This is done by finding the square roots of the
|
||||
*> roots of the secular equation via the routine SLASD4 (as called
|
||||
*> by SLASD3). This routine also calculates the singular vectors of
|
||||
*> the current problem.
|
||||
*>
|
||||
*> The final stage consists of computing the updated singular vectors
|
||||
*> directly using the updated singular values. The singular vectors
|
||||
*> for the current problem are multiplied with the singular vectors
|
||||
*> from the overall problem.
|
||||
*> \endverbatim
|
||||
*
|
||||
* Arguments:
|
||||
* ==========
|
||||
*
|
||||
*> \param[in] NL
|
||||
*> \verbatim
|
||||
*> NL is INTEGER
|
||||
*> The row dimension of the upper block. NL >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] NR
|
||||
*> \verbatim
|
||||
*> NR is INTEGER
|
||||
*> The row dimension of the lower block. NR >= 1.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] SQRE
|
||||
*> \verbatim
|
||||
*> SQRE is INTEGER
|
||||
*> = 0: the lower block is an NR-by-NR square matrix.
|
||||
*> = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
|
||||
*>
|
||||
*> The bidiagonal matrix has row dimension N = NL + NR + 1,
|
||||
*> and column dimension M = N + SQRE.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] D
|
||||
*> \verbatim
|
||||
*> D is REAL array, dimension (NL+NR+1).
|
||||
*> N = NL+NR+1
|
||||
*> On entry D(1:NL,1:NL) contains the singular values of the
|
||||
*> upper block; and D(NL+2:N) contains the singular values of
|
||||
*> the lower block. On exit D(1:N) contains the singular values
|
||||
*> of the modified matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] ALPHA
|
||||
*> \verbatim
|
||||
*> ALPHA is REAL
|
||||
*> Contains the diagonal element associated with the added row.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] BETA
|
||||
*> \verbatim
|
||||
*> BETA is REAL
|
||||
*> Contains the off-diagonal element associated with the added
|
||||
*> row.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] U
|
||||
*> \verbatim
|
||||
*> U is REAL array, dimension (LDU,N)
|
||||
*> On entry U(1:NL, 1:NL) contains the left singular vectors of
|
||||
*> the upper block; U(NL+2:N, NL+2:N) contains the left singular
|
||||
*> vectors of the lower block. On exit U contains the left
|
||||
*> singular vectors of the bidiagonal matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDU
|
||||
*> \verbatim
|
||||
*> LDU is INTEGER
|
||||
*> The leading dimension of the array U. LDU >= max( 1, N ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in,out] VT
|
||||
*> \verbatim
|
||||
*> VT is REAL array, dimension (LDVT,M)
|
||||
*> where M = N + SQRE.
|
||||
*> On entry VT(1:NL+1, 1:NL+1)**T contains the right singular
|
||||
*> vectors of the upper block; VT(NL+2:M, NL+2:M)**T contains
|
||||
*> the right singular vectors of the lower block. On exit
|
||||
*> VT**T contains the right singular vectors of the
|
||||
*> bidiagonal matrix.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[in] LDVT
|
||||
*> \verbatim
|
||||
*> LDVT is INTEGER
|
||||
*> The leading dimension of the array VT. LDVT >= max( 1, M ).
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] IDXQ
|
||||
*> \verbatim
|
||||
*> IDXQ is INTEGER array, dimension (N)
|
||||
*> This contains the permutation which will reintegrate the
|
||||
*> subproblem just solved back into sorted order, i.e.
|
||||
*> D( IDXQ( I = 1, N ) ) will be in ascending order.
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] IWORK
|
||||
*> \verbatim
|
||||
*> IWORK is INTEGER array, dimension (4*N)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] WORK
|
||||
*> \verbatim
|
||||
*> WORK is REAL array, dimension (3*M**2+2*M)
|
||||
*> \endverbatim
|
||||
*>
|
||||
*> \param[out] INFO
|
||||
*> \verbatim
|
||||
*> INFO is INTEGER
|
||||
*> = 0: successful exit.
|
||||
*> < 0: if INFO = -i, the i-th argument had an illegal value.
|
||||
*> > 0: if INFO = 1, a singular value did not converge
|
||||
*> \endverbatim
|
||||
*
|
||||
* Authors:
|
||||
* ========
|
||||
*
|
||||
*> \author Univ. of Tennessee
|
||||
*> \author Univ. of California Berkeley
|
||||
*> \author Univ. of Colorado Denver
|
||||
*> \author NAG Ltd.
|
||||
*
|
||||
*> \date September 2012
|
||||
*
|
||||
*> \ingroup auxOTHERauxiliary
|
||||
*
|
||||
*> \par Contributors:
|
||||
* ==================
|
||||
*>
|
||||
*> Ming Gu and Huan Ren, Computer Science Division, University of
|
||||
*> California at Berkeley, USA
|
||||
*>
|
||||
* =====================================================================
|
||||
SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
|
||||
$ IDXQ, IWORK, WORK, INFO )
|
||||
*
|
||||
* -- LAPACK auxiliary routine (version 3.4.2) --
|
||||
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||||
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||||
* September 2012
|
||||
*
|
||||
* .. Scalar Arguments ..
|
||||
INTEGER INFO, LDU, LDVT, NL, NR, SQRE
|
||||
REAL ALPHA, BETA
|
||||
* ..
|
||||
* .. Array Arguments ..
|
||||
INTEGER IDXQ( * ), IWORK( * )
|
||||
REAL D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
|
||||
* ..
|
||||
*
|
||||
* =====================================================================
|
||||
*
|
||||
* .. Parameters ..
|
||||
*
|
||||
REAL ONE, ZERO
|
||||
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
|
||||
* ..
|
||||
* .. Local Scalars ..
|
||||
INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
|
||||
$ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
|
||||
REAL ORGNRM
|
||||
* ..
|
||||
* .. External Subroutines ..
|
||||
EXTERNAL SLAMRG, SLASCL, SLASD2, SLASD3, XERBLA
|
||||
* ..
|
||||
* .. Intrinsic Functions ..
|
||||
INTRINSIC ABS, MAX
|
||||
* ..
|
||||
* .. Executable Statements ..
|
||||
*
|
||||
* Test the input parameters.
|
||||
*
|
||||
INFO = 0
|
||||
*
|
||||
IF( NL.LT.1 ) THEN
|
||||
INFO = -1
|
||||
ELSE IF( NR.LT.1 ) THEN
|
||||
INFO = -2
|
||||
ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
|
||||
INFO = -3
|
||||
END IF
|
||||
IF( INFO.NE.0 ) THEN
|
||||
CALL XERBLA( 'SLASD1', -INFO )
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
N = NL + NR + 1
|
||||
M = N + SQRE
|
||||
*
|
||||
* The following values are for bookkeeping purposes only. They are
|
||||
* integer pointers which indicate the portion of the workspace
|
||||
* used by a particular array in SLASD2 and SLASD3.
|
||||
*
|
||||
LDU2 = N
|
||||
LDVT2 = M
|
||||
*
|
||||
IZ = 1
|
||||
ISIGMA = IZ + M
|
||||
IU2 = ISIGMA + N
|
||||
IVT2 = IU2 + LDU2*N
|
||||
IQ = IVT2 + LDVT2*M
|
||||
*
|
||||
IDX = 1
|
||||
IDXC = IDX + N
|
||||
COLTYP = IDXC + N
|
||||
IDXP = COLTYP + N
|
||||
*
|
||||
* Scale.
|
||||
*
|
||||
ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
|
||||
D( NL+1 ) = ZERO
|
||||
DO 10 I = 1, N
|
||||
IF( ABS( D( I ) ).GT.ORGNRM ) THEN
|
||||
ORGNRM = ABS( D( I ) )
|
||||
END IF
|
||||
10 CONTINUE
|
||||
CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
|
||||
ALPHA = ALPHA / ORGNRM
|
||||
BETA = BETA / ORGNRM
|
||||
*
|
||||
* Deflate singular values.
|
||||
*
|
||||
CALL SLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
|
||||
$ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
|
||||
$ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
|
||||
$ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
|
||||
*
|
||||
* Solve Secular Equation and update singular vectors.
|
||||
*
|
||||
LDQ = K
|
||||
CALL SLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
|
||||
$ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
|
||||
$ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
|
||||
$ INFO )
|
||||
IF( INFO.NE.0 ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
*
|
||||
* Unscale.
|
||||
*
|
||||
CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
|
||||
*
|
||||
* Prepare the IDXQ sorting permutation.
|
||||
*
|
||||
N1 = K
|
||||
N2 = N - K
|
||||
CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
|
||||
*
|
||||
RETURN
|
||||
*
|
||||
* End of SLASD1
|
||||
*
|
||||
END
|
||||
Reference in New Issue
Block a user