00001 SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, 00002 $ VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, 00003 $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, 00004 $ C, S, INFO ) 00005 * 00006 * -- LAPACK auxiliary routine (version 3.2) -- 00007 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00008 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00009 * November 2006 00010 * 00011 * .. Scalar Arguments .. 00012 INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, 00013 $ NR, SQRE 00014 REAL ALPHA, BETA, C, S 00015 * .. 00016 * .. Array Arguments .. 00017 INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), 00018 $ IDXQ( * ), PERM( * ) 00019 REAL D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), 00020 $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), 00021 $ ZW( * ) 00022 * .. 00023 * 00024 * Purpose 00025 * ======= 00026 * 00027 * SLASD7 merges the two sets of singular values together into a single 00028 * sorted set. Then it tries to deflate the size of the problem. There 00029 * are two ways in which deflation can occur: when two or more singular 00030 * values are close together or if there is a tiny entry in the Z 00031 * vector. For each such occurrence the order of the related 00032 * secular equation problem is reduced by one. 00033 * 00034 * SLASD7 is called from SLASD6. 00035 * 00036 * Arguments 00037 * ========= 00038 * 00039 * ICOMPQ (input) INTEGER 00040 * Specifies whether singular vectors are to be computed 00041 * in compact form, as follows: 00042 * = 0: Compute singular values only. 00043 * = 1: Compute singular vectors of upper 00044 * bidiagonal matrix in compact form. 00045 * 00046 * NL (input) INTEGER 00047 * The row dimension of the upper block. NL >= 1. 00048 * 00049 * NR (input) INTEGER 00050 * The row dimension of the lower block. NR >= 1. 00051 * 00052 * SQRE (input) INTEGER 00053 * = 0: the lower block is an NR-by-NR square matrix. 00054 * = 1: the lower block is an NR-by-(NR+1) rectangular matrix. 00055 * 00056 * The bidiagonal matrix has 00057 * N = NL + NR + 1 rows and 00058 * M = N + SQRE >= N columns. 00059 * 00060 * K (output) INTEGER 00061 * Contains the dimension of the non-deflated matrix, this is 00062 * the order of the related secular equation. 1 <= K <=N. 00063 * 00064 * D (input/output) REAL array, dimension ( N ) 00065 * On entry D contains the singular values of the two submatrices 00066 * to be combined. On exit D contains the trailing (N-K) updated 00067 * singular values (those which were deflated) sorted into 00068 * increasing order. 00069 * 00070 * Z (output) REAL array, dimension ( M ) 00071 * On exit Z contains the updating row vector in the secular 00072 * equation. 00073 * 00074 * ZW (workspace) REAL array, dimension ( M ) 00075 * Workspace for Z. 00076 * 00077 * VF (input/output) REAL array, dimension ( M ) 00078 * On entry, VF(1:NL+1) contains the first components of all 00079 * right singular vectors of the upper block; and VF(NL+2:M) 00080 * contains the first components of all right singular vectors 00081 * of the lower block. On exit, VF contains the first components 00082 * of all right singular vectors of the bidiagonal matrix. 00083 * 00084 * VFW (workspace) REAL array, dimension ( M ) 00085 * Workspace for VF. 00086 * 00087 * VL (input/output) REAL array, dimension ( M ) 00088 * On entry, VL(1:NL+1) contains the last components of all 00089 * right singular vectors of the upper block; and VL(NL+2:M) 00090 * contains the last components of all right singular vectors 00091 * of the lower block. On exit, VL contains the last components 00092 * of all right singular vectors of the bidiagonal matrix. 00093 * 00094 * VLW (workspace) REAL array, dimension ( M ) 00095 * Workspace for VL. 00096 * 00097 * ALPHA (input) REAL 00098 * Contains the diagonal element associated with the added row. 00099 * 00100 * BETA (input) REAL 00101 * Contains the off-diagonal element associated with the added 00102 * row. 00103 * 00104 * DSIGMA (output) REAL array, dimension ( N ) 00105 * Contains a copy of the diagonal elements (K-1 singular values 00106 * and one zero) in the secular equation. 00107 * 00108 * IDX (workspace) INTEGER array, dimension ( N ) 00109 * This will contain the permutation used to sort the contents of 00110 * D into ascending order. 00111 * 00112 * IDXP (workspace) INTEGER array, dimension ( N ) 00113 * This will contain the permutation used to place deflated 00114 * values of D at the end of the array. On output IDXP(2:K) 00115 * points to the nondeflated D-values and IDXP(K+1:N) 00116 * points to the deflated singular values. 00117 * 00118 * IDXQ (input) INTEGER array, dimension ( N ) 00119 * This contains the permutation which separately sorts the two 00120 * sub-problems in D into ascending order. Note that entries in 00121 * the first half of this permutation must first be moved one 00122 * position backward; and entries in the second half 00123 * must first have NL+1 added to their values. 00124 * 00125 * PERM (output) INTEGER array, dimension ( N ) 00126 * The permutations (from deflation and sorting) to be applied 00127 * to each singular block. Not referenced if ICOMPQ = 0. 00128 * 00129 * GIVPTR (output) INTEGER 00130 * The number of Givens rotations which took place in this 00131 * subproblem. Not referenced if ICOMPQ = 0. 00132 * 00133 * GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) 00134 * Each pair of numbers indicates a pair of columns to take place 00135 * in a Givens rotation. Not referenced if ICOMPQ = 0. 00136 * 00137 * LDGCOL (input) INTEGER 00138 * The leading dimension of GIVCOL, must be at least N. 00139 * 00140 * GIVNUM (output) REAL array, dimension ( LDGNUM, 2 ) 00141 * Each number indicates the C or S value to be used in the 00142 * corresponding Givens rotation. Not referenced if ICOMPQ = 0. 00143 * 00144 * LDGNUM (input) INTEGER 00145 * The leading dimension of GIVNUM, must be at least N. 00146 * 00147 * C (output) REAL 00148 * C contains garbage if SQRE =0 and the C-value of a Givens 00149 * rotation related to the right null space if SQRE = 1. 00150 * 00151 * S (output) REAL 00152 * S contains garbage if SQRE =0 and the S-value of a Givens 00153 * rotation related to the right null space if SQRE = 1. 00154 * 00155 * INFO (output) INTEGER 00156 * = 0: successful exit. 00157 * < 0: if INFO = -i, the i-th argument had an illegal value. 00158 * 00159 * Further Details 00160 * =============== 00161 * 00162 * Based on contributions by 00163 * Ming Gu and Huan Ren, Computer Science Division, University of 00164 * California at Berkeley, USA 00165 * 00166 * ===================================================================== 00167 * 00168 * .. Parameters .. 00169 REAL ZERO, ONE, TWO, EIGHT 00170 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0, 00171 $ EIGHT = 8.0E+0 ) 00172 * .. 00173 * .. Local Scalars .. 00174 * 00175 INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N, 00176 $ NLP1, NLP2 00177 REAL EPS, HLFTOL, TAU, TOL, Z1 00178 * .. 00179 * .. External Subroutines .. 00180 EXTERNAL SCOPY, SLAMRG, SROT, XERBLA 00181 * .. 00182 * .. External Functions .. 00183 REAL SLAMCH, SLAPY2 00184 EXTERNAL SLAMCH, SLAPY2 00185 * .. 00186 * .. Intrinsic Functions .. 00187 INTRINSIC ABS, MAX 00188 * .. 00189 * .. Executable Statements .. 00190 * 00191 * Test the input parameters. 00192 * 00193 INFO = 0 00194 N = NL + NR + 1 00195 M = N + SQRE 00196 * 00197 IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN 00198 INFO = -1 00199 ELSE IF( NL.LT.1 ) THEN 00200 INFO = -2 00201 ELSE IF( NR.LT.1 ) THEN 00202 INFO = -3 00203 ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN 00204 INFO = -4 00205 ELSE IF( LDGCOL.LT.N ) THEN 00206 INFO = -22 00207 ELSE IF( LDGNUM.LT.N ) THEN 00208 INFO = -24 00209 END IF 00210 IF( INFO.NE.0 ) THEN 00211 CALL XERBLA( 'SLASD7', -INFO ) 00212 RETURN 00213 END IF 00214 * 00215 NLP1 = NL + 1 00216 NLP2 = NL + 2 00217 IF( ICOMPQ.EQ.1 ) THEN 00218 GIVPTR = 0 00219 END IF 00220 * 00221 * Generate the first part of the vector Z and move the singular 00222 * values in the first part of D one position backward. 00223 * 00224 Z1 = ALPHA*VL( NLP1 ) 00225 VL( NLP1 ) = ZERO 00226 TAU = VF( NLP1 ) 00227 DO 10 I = NL, 1, -1 00228 Z( I+1 ) = ALPHA*VL( I ) 00229 VL( I ) = ZERO 00230 VF( I+1 ) = VF( I ) 00231 D( I+1 ) = D( I ) 00232 IDXQ( I+1 ) = IDXQ( I ) + 1 00233 10 CONTINUE 00234 VF( 1 ) = TAU 00235 * 00236 * Generate the second part of the vector Z. 00237 * 00238 DO 20 I = NLP2, M 00239 Z( I ) = BETA*VF( I ) 00240 VF( I ) = ZERO 00241 20 CONTINUE 00242 * 00243 * Sort the singular values into increasing order 00244 * 00245 DO 30 I = NLP2, N 00246 IDXQ( I ) = IDXQ( I ) + NLP1 00247 30 CONTINUE 00248 * 00249 * DSIGMA, IDXC, IDXC, and ZW are used as storage space. 00250 * 00251 DO 40 I = 2, N 00252 DSIGMA( I ) = D( IDXQ( I ) ) 00253 ZW( I ) = Z( IDXQ( I ) ) 00254 VFW( I ) = VF( IDXQ( I ) ) 00255 VLW( I ) = VL( IDXQ( I ) ) 00256 40 CONTINUE 00257 * 00258 CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) 00259 * 00260 DO 50 I = 2, N 00261 IDXI = 1 + IDX( I ) 00262 D( I ) = DSIGMA( IDXI ) 00263 Z( I ) = ZW( IDXI ) 00264 VF( I ) = VFW( IDXI ) 00265 VL( I ) = VLW( IDXI ) 00266 50 CONTINUE 00267 * 00268 * Calculate the allowable deflation tolerence 00269 * 00270 EPS = SLAMCH( 'Epsilon' ) 00271 TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) 00272 TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) 00273 * 00274 * There are 2 kinds of deflation -- first a value in the z-vector 00275 * is small, second two (or more) singular values are very close 00276 * together (their difference is small). 00277 * 00278 * If the value in the z-vector is small, we simply permute the 00279 * array so that the corresponding singular value is moved to the 00280 * end. 00281 * 00282 * If two values in the D-vector are close, we perform a two-sided 00283 * rotation designed to make one of the corresponding z-vector 00284 * entries zero, and then permute the array so that the deflated 00285 * singular value is moved to the end. 00286 * 00287 * If there are multiple singular values then the problem deflates. 00288 * Here the number of equal singular values are found. As each equal 00289 * singular value is found, an elementary reflector is computed to 00290 * rotate the corresponding singular subspace so that the 00291 * corresponding components of Z are zero in this new basis. 00292 * 00293 K = 1 00294 K2 = N + 1 00295 DO 60 J = 2, N 00296 IF( ABS( Z( J ) ).LE.TOL ) THEN 00297 * 00298 * Deflate due to small z component. 00299 * 00300 K2 = K2 - 1 00301 IDXP( K2 ) = J 00302 IF( J.EQ.N ) 00303 $ GO TO 100 00304 ELSE 00305 JPREV = J 00306 GO TO 70 00307 END IF 00308 60 CONTINUE 00309 70 CONTINUE 00310 J = JPREV 00311 80 CONTINUE 00312 J = J + 1 00313 IF( J.GT.N ) 00314 $ GO TO 90 00315 IF( ABS( Z( J ) ).LE.TOL ) THEN 00316 * 00317 * Deflate due to small z component. 00318 * 00319 K2 = K2 - 1 00320 IDXP( K2 ) = J 00321 ELSE 00322 * 00323 * Check if singular values are close enough to allow deflation. 00324 * 00325 IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN 00326 * 00327 * Deflation is possible. 00328 * 00329 S = Z( JPREV ) 00330 C = Z( J ) 00331 * 00332 * Find sqrt(a**2+b**2) without overflow or 00333 * destructive underflow. 00334 * 00335 TAU = SLAPY2( C, S ) 00336 Z( J ) = TAU 00337 Z( JPREV ) = ZERO 00338 C = C / TAU 00339 S = -S / TAU 00340 * 00341 * Record the appropriate Givens rotation 00342 * 00343 IF( ICOMPQ.EQ.1 ) THEN 00344 GIVPTR = GIVPTR + 1 00345 IDXJP = IDXQ( IDX( JPREV )+1 ) 00346 IDXJ = IDXQ( IDX( J )+1 ) 00347 IF( IDXJP.LE.NLP1 ) THEN 00348 IDXJP = IDXJP - 1 00349 END IF 00350 IF( IDXJ.LE.NLP1 ) THEN 00351 IDXJ = IDXJ - 1 00352 END IF 00353 GIVCOL( GIVPTR, 2 ) = IDXJP 00354 GIVCOL( GIVPTR, 1 ) = IDXJ 00355 GIVNUM( GIVPTR, 2 ) = C 00356 GIVNUM( GIVPTR, 1 ) = S 00357 END IF 00358 CALL SROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S ) 00359 CALL SROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S ) 00360 K2 = K2 - 1 00361 IDXP( K2 ) = JPREV 00362 JPREV = J 00363 ELSE 00364 K = K + 1 00365 ZW( K ) = Z( JPREV ) 00366 DSIGMA( K ) = D( JPREV ) 00367 IDXP( K ) = JPREV 00368 JPREV = J 00369 END IF 00370 END IF 00371 GO TO 80 00372 90 CONTINUE 00373 * 00374 * Record the last singular value. 00375 * 00376 K = K + 1 00377 ZW( K ) = Z( JPREV ) 00378 DSIGMA( K ) = D( JPREV ) 00379 IDXP( K ) = JPREV 00380 * 00381 100 CONTINUE 00382 * 00383 * Sort the singular values into DSIGMA. The singular values which 00384 * were not deflated go into the first K slots of DSIGMA, except 00385 * that DSIGMA(1) is treated separately. 00386 * 00387 DO 110 J = 2, N 00388 JP = IDXP( J ) 00389 DSIGMA( J ) = D( JP ) 00390 VFW( J ) = VF( JP ) 00391 VLW( J ) = VL( JP ) 00392 110 CONTINUE 00393 IF( ICOMPQ.EQ.1 ) THEN 00394 DO 120 J = 2, N 00395 JP = IDXP( J ) 00396 PERM( J ) = IDXQ( IDX( JP )+1 ) 00397 IF( PERM( J ).LE.NLP1 ) THEN 00398 PERM( J ) = PERM( J ) - 1 00399 END IF 00400 120 CONTINUE 00401 END IF 00402 * 00403 * The deflated singular values go back into the last N - K slots of 00404 * D. 00405 * 00406 CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) 00407 * 00408 * Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and 00409 * VL(M). 00410 * 00411 DSIGMA( 1 ) = ZERO 00412 HLFTOL = TOL / TWO 00413 IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) 00414 $ DSIGMA( 2 ) = HLFTOL 00415 IF( M.GT.N ) THEN 00416 Z( 1 ) = SLAPY2( Z1, Z( M ) ) 00417 IF( Z( 1 ).LE.TOL ) THEN 00418 C = ONE 00419 S = ZERO 00420 Z( 1 ) = TOL 00421 ELSE 00422 C = Z1 / Z( 1 ) 00423 S = -Z( M ) / Z( 1 ) 00424 END IF 00425 CALL SROT( 1, VF( M ), 1, VF( 1 ), 1, C, S ) 00426 CALL SROT( 1, VL( M ), 1, VL( 1 ), 1, C, S ) 00427 ELSE 00428 IF( ABS( Z1 ).LE.TOL ) THEN 00429 Z( 1 ) = TOL 00430 ELSE 00431 Z( 1 ) = Z1 00432 END IF 00433 END IF 00434 * 00435 * Restore Z, VF, and VL. 00436 * 00437 CALL SCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 ) 00438 CALL SCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 ) 00439 CALL SCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 ) 00440 * 00441 RETURN 00442 * 00443 * End of SLASD7 00444 * 00445 END
1.7.2