![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SLASD2 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download SLASD2 + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasd2.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasd2.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasd2.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, 00022 * LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, 00023 * IDXC, IDXQ, COLTYP, INFO ) 00024 * 00025 * .. Scalar Arguments .. 00026 * INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE 00027 * REAL ALPHA, BETA 00028 * .. 00029 * .. Array Arguments .. 00030 * INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), 00031 * $ IDXQ( * ) 00032 * REAL D( * ), DSIGMA( * ), U( LDU, * ), 00033 * $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), 00034 * $ Z( * ) 00035 * .. 00036 * 00037 * 00038 *> \par Purpose: 00039 * ============= 00040 *> 00041 *> \verbatim 00042 *> 00043 *> SLASD2 merges the two sets of singular values together into a single 00044 *> sorted set. Then it tries to deflate the size of the problem. 00045 *> There are two ways in which deflation can occur: when two or more 00046 *> singular values are close together or if there is a tiny entry in the 00047 *> Z vector. For each such occurrence the order of the related secular 00048 *> equation problem is reduced by one. 00049 *> 00050 *> SLASD2 is called from SLASD1. 00051 *> \endverbatim 00052 * 00053 * Arguments: 00054 * ========== 00055 * 00056 *> \param[in] NL 00057 *> \verbatim 00058 *> NL is INTEGER 00059 *> The row dimension of the upper block. NL >= 1. 00060 *> \endverbatim 00061 *> 00062 *> \param[in] NR 00063 *> \verbatim 00064 *> NR is INTEGER 00065 *> The row dimension of the lower block. NR >= 1. 00066 *> \endverbatim 00067 *> 00068 *> \param[in] SQRE 00069 *> \verbatim 00070 *> SQRE is INTEGER 00071 *> = 0: the lower block is an NR-by-NR square matrix. 00072 *> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. 00073 *> 00074 *> The bidiagonal matrix has N = NL + NR + 1 rows and 00075 *> M = N + SQRE >= N columns. 00076 *> \endverbatim 00077 *> 00078 *> \param[out] K 00079 *> \verbatim 00080 *> K is INTEGER 00081 *> Contains the dimension of the non-deflated matrix, 00082 *> This is the order of the related secular equation. 1 <= K <=N. 00083 *> \endverbatim 00084 *> 00085 *> \param[in,out] D 00086 *> \verbatim 00087 *> D is REAL array, dimension (N) 00088 *> On entry D contains the singular values of the two submatrices 00089 *> to be combined. On exit D contains the trailing (N-K) updated 00090 *> singular values (those which were deflated) sorted into 00091 *> increasing order. 00092 *> \endverbatim 00093 *> 00094 *> \param[out] Z 00095 *> \verbatim 00096 *> Z is REAL array, dimension (N) 00097 *> On exit Z contains the updating row vector in the secular 00098 *> equation. 00099 *> \endverbatim 00100 *> 00101 *> \param[in] ALPHA 00102 *> \verbatim 00103 *> ALPHA is REAL 00104 *> Contains the diagonal element associated with the added row. 00105 *> \endverbatim 00106 *> 00107 *> \param[in] BETA 00108 *> \verbatim 00109 *> BETA is REAL 00110 *> Contains the off-diagonal element associated with the added 00111 *> row. 00112 *> \endverbatim 00113 *> 00114 *> \param[in,out] U 00115 *> \verbatim 00116 *> U is REAL array, dimension (LDU,N) 00117 *> On entry U contains the left singular vectors of two 00118 *> submatrices in the two square blocks with corners at (1,1), 00119 *> (NL, NL), and (NL+2, NL+2), (N,N). 00120 *> On exit U contains the trailing (N-K) updated left singular 00121 *> vectors (those which were deflated) in its last N-K columns. 00122 *> \endverbatim 00123 *> 00124 *> \param[in] LDU 00125 *> \verbatim 00126 *> LDU is INTEGER 00127 *> The leading dimension of the array U. LDU >= N. 00128 *> \endverbatim 00129 *> 00130 *> \param[in,out] VT 00131 *> \verbatim 00132 *> VT is REAL array, dimension (LDVT,M) 00133 *> On entry VT**T contains the right singular vectors of two 00134 *> submatrices in the two square blocks with corners at (1,1), 00135 *> (NL+1, NL+1), and (NL+2, NL+2), (M,M). 00136 *> On exit VT**T contains the trailing (N-K) updated right singular 00137 *> vectors (those which were deflated) in its last N-K columns. 00138 *> In case SQRE =1, the last row of VT spans the right null 00139 *> space. 00140 *> \endverbatim 00141 *> 00142 *> \param[in] LDVT 00143 *> \verbatim 00144 *> LDVT is INTEGER 00145 *> The leading dimension of the array VT. LDVT >= M. 00146 *> \endverbatim 00147 *> 00148 *> \param[out] DSIGMA 00149 *> \verbatim 00150 *> DSIGMA is REAL array, dimension (N) 00151 *> Contains a copy of the diagonal elements (K-1 singular values 00152 *> and one zero) in the secular equation. 00153 *> \endverbatim 00154 *> 00155 *> \param[out] U2 00156 *> \verbatim 00157 *> U2 is REAL array, dimension (LDU2,N) 00158 *> Contains a copy of the first K-1 left singular vectors which 00159 *> will be used by SLASD3 in a matrix multiply (SGEMM) to solve 00160 *> for the new left singular vectors. U2 is arranged into four 00161 *> blocks. The first block contains a column with 1 at NL+1 and 00162 *> zero everywhere else; the second block contains non-zero 00163 *> entries only at and above NL; the third contains non-zero 00164 *> entries only below NL+1; and the fourth is dense. 00165 *> \endverbatim 00166 *> 00167 *> \param[in] LDU2 00168 *> \verbatim 00169 *> LDU2 is INTEGER 00170 *> The leading dimension of the array U2. LDU2 >= N. 00171 *> \endverbatim 00172 *> 00173 *> \param[out] VT2 00174 *> \verbatim 00175 *> VT2 is REAL array, dimension (LDVT2,N) 00176 *> VT2**T contains a copy of the first K right singular vectors 00177 *> which will be used by SLASD3 in a matrix multiply (SGEMM) to 00178 *> solve for the new right singular vectors. VT2 is arranged into 00179 *> three blocks. The first block contains a row that corresponds 00180 *> to the special 0 diagonal element in SIGMA; the second block 00181 *> contains non-zeros only at and before NL +1; the third block 00182 *> contains non-zeros only at and after NL +2. 00183 *> \endverbatim 00184 *> 00185 *> \param[in] LDVT2 00186 *> \verbatim 00187 *> LDVT2 is INTEGER 00188 *> The leading dimension of the array VT2. LDVT2 >= M. 00189 *> \endverbatim 00190 *> 00191 *> \param[out] IDXP 00192 *> \verbatim 00193 *> IDXP is INTEGER array, dimension (N) 00194 *> This will contain the permutation used to place deflated 00195 *> values of D at the end of the array. On output IDXP(2:K) 00196 *> points to the nondeflated D-values and IDXP(K+1:N) 00197 *> points to the deflated singular values. 00198 *> \endverbatim 00199 *> 00200 *> \param[out] IDX 00201 *> \verbatim 00202 *> IDX is INTEGER array, dimension (N) 00203 *> This will contain the permutation used to sort the contents of 00204 *> D into ascending order. 00205 *> \endverbatim 00206 *> 00207 *> \param[out] IDXC 00208 *> \verbatim 00209 *> IDXC is INTEGER array, dimension (N) 00210 *> This will contain the permutation used to arrange the columns 00211 *> of the deflated U matrix into three groups: the first group 00212 *> contains non-zero entries only at and above NL, the second 00213 *> contains non-zero entries only below NL+2, and the third is 00214 *> dense. 00215 *> \endverbatim 00216 *> 00217 *> \param[in,out] IDXQ 00218 *> \verbatim 00219 *> IDXQ is INTEGER array, dimension (N) 00220 *> This contains the permutation which separately sorts the two 00221 *> sub-problems in D into ascending order. Note that entries in 00222 *> the first hlaf of this permutation must first be moved one 00223 *> position backward; and entries in the second half 00224 *> must first have NL+1 added to their values. 00225 *> \endverbatim 00226 *> 00227 *> \param[out] COLTYP 00228 *> \verbatim 00229 *> COLTYP is INTEGER array, dimension (N) 00230 *> As workspace, this will contain a label which will indicate 00231 *> which of the following types a column in the U2 matrix or a 00232 *> row in the VT2 matrix is: 00233 *> 1 : non-zero in the upper half only 00234 *> 2 : non-zero in the lower half only 00235 *> 3 : dense 00236 *> 4 : deflated 00237 *> 00238 *> On exit, it is an array of dimension 4, with COLTYP(I) being 00239 *> the dimension of the I-th type columns. 00240 *> \endverbatim 00241 *> 00242 *> \param[out] INFO 00243 *> \verbatim 00244 *> INFO is INTEGER 00245 *> = 0: successful exit. 00246 *> < 0: if INFO = -i, the i-th argument had an illegal value. 00247 *> \endverbatim 00248 * 00249 * Authors: 00250 * ======== 00251 * 00252 *> \author Univ. of Tennessee 00253 *> \author Univ. of California Berkeley 00254 *> \author Univ. of Colorado Denver 00255 *> \author NAG Ltd. 00256 * 00257 *> \date November 2011 00258 * 00259 *> \ingroup auxOTHERauxiliary 00260 * 00261 *> \par Contributors: 00262 * ================== 00263 *> 00264 *> Ming Gu and Huan Ren, Computer Science Division, University of 00265 *> California at Berkeley, USA 00266 *> 00267 * ===================================================================== 00268 SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, 00269 $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, 00270 $ IDXC, IDXQ, COLTYP, INFO ) 00271 * 00272 * -- LAPACK auxiliary routine (version 3.4.0) -- 00273 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00274 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00275 * November 2011 00276 * 00277 * .. Scalar Arguments .. 00278 INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE 00279 REAL ALPHA, BETA 00280 * .. 00281 * .. Array Arguments .. 00282 INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), 00283 $ IDXQ( * ) 00284 REAL D( * ), DSIGMA( * ), U( LDU, * ), 00285 $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), 00286 $ Z( * ) 00287 * .. 00288 * 00289 * ===================================================================== 00290 * 00291 * .. Parameters .. 00292 REAL ZERO, ONE, TWO, EIGHT 00293 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0, 00294 $ EIGHT = 8.0E+0 ) 00295 * .. 00296 * .. Local Arrays .. 00297 INTEGER CTOT( 4 ), PSM( 4 ) 00298 * .. 00299 * .. Local Scalars .. 00300 INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, 00301 $ N, NLP1, NLP2 00302 REAL C, EPS, HLFTOL, S, TAU, TOL, Z1 00303 * .. 00304 * .. External Functions .. 00305 REAL SLAMCH, SLAPY2 00306 EXTERNAL SLAMCH, SLAPY2 00307 * .. 00308 * .. External Subroutines .. 00309 EXTERNAL SCOPY, SLACPY, SLAMRG, SLASET, SROT, XERBLA 00310 * .. 00311 * .. Intrinsic Functions .. 00312 INTRINSIC ABS, MAX 00313 * .. 00314 * .. Executable Statements .. 00315 * 00316 * Test the input parameters. 00317 * 00318 INFO = 0 00319 * 00320 IF( NL.LT.1 ) THEN 00321 INFO = -1 00322 ELSE IF( NR.LT.1 ) THEN 00323 INFO = -2 00324 ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN 00325 INFO = -3 00326 END IF 00327 * 00328 N = NL + NR + 1 00329 M = N + SQRE 00330 * 00331 IF( LDU.LT.N ) THEN 00332 INFO = -10 00333 ELSE IF( LDVT.LT.M ) THEN 00334 INFO = -12 00335 ELSE IF( LDU2.LT.N ) THEN 00336 INFO = -15 00337 ELSE IF( LDVT2.LT.M ) THEN 00338 INFO = -17 00339 END IF 00340 IF( INFO.NE.0 ) THEN 00341 CALL XERBLA( 'SLASD2', -INFO ) 00342 RETURN 00343 END IF 00344 * 00345 NLP1 = NL + 1 00346 NLP2 = NL + 2 00347 * 00348 * Generate the first part of the vector Z; and move the singular 00349 * values in the first part of D one position backward. 00350 * 00351 Z1 = ALPHA*VT( NLP1, NLP1 ) 00352 Z( 1 ) = Z1 00353 DO 10 I = NL, 1, -1 00354 Z( I+1 ) = ALPHA*VT( I, NLP1 ) 00355 D( I+1 ) = D( I ) 00356 IDXQ( I+1 ) = IDXQ( I ) + 1 00357 10 CONTINUE 00358 * 00359 * Generate the second part of the vector Z. 00360 * 00361 DO 20 I = NLP2, M 00362 Z( I ) = BETA*VT( I, NLP2 ) 00363 20 CONTINUE 00364 * 00365 * Initialize some reference arrays. 00366 * 00367 DO 30 I = 2, NLP1 00368 COLTYP( I ) = 1 00369 30 CONTINUE 00370 DO 40 I = NLP2, N 00371 COLTYP( I ) = 2 00372 40 CONTINUE 00373 * 00374 * Sort the singular values into increasing order 00375 * 00376 DO 50 I = NLP2, N 00377 IDXQ( I ) = IDXQ( I ) + NLP1 00378 50 CONTINUE 00379 * 00380 * DSIGMA, IDXC, IDXC, and the first column of U2 00381 * are used as storage space. 00382 * 00383 DO 60 I = 2, N 00384 DSIGMA( I ) = D( IDXQ( I ) ) 00385 U2( I, 1 ) = Z( IDXQ( I ) ) 00386 IDXC( I ) = COLTYP( IDXQ( I ) ) 00387 60 CONTINUE 00388 * 00389 CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) ) 00390 * 00391 DO 70 I = 2, N 00392 IDXI = 1 + IDX( I ) 00393 D( I ) = DSIGMA( IDXI ) 00394 Z( I ) = U2( IDXI, 1 ) 00395 COLTYP( I ) = IDXC( IDXI ) 00396 70 CONTINUE 00397 * 00398 * Calculate the allowable deflation tolerance 00399 * 00400 EPS = SLAMCH( 'Epsilon' ) 00401 TOL = MAX( ABS( ALPHA ), ABS( BETA ) ) 00402 TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL ) 00403 * 00404 * There are 2 kinds of deflation -- first a value in the z-vector 00405 * is small, second two (or more) singular values are very close 00406 * together (their difference is small). 00407 * 00408 * If the value in the z-vector is small, we simply permute the 00409 * array so that the corresponding singular value is moved to the 00410 * end. 00411 * 00412 * If two values in the D-vector are close, we perform a two-sided 00413 * rotation designed to make one of the corresponding z-vector 00414 * entries zero, and then permute the array so that the deflated 00415 * singular value is moved to the end. 00416 * 00417 * If there are multiple singular values then the problem deflates. 00418 * Here the number of equal singular values are found. As each equal 00419 * singular value is found, an elementary reflector is computed to 00420 * rotate the corresponding singular subspace so that the 00421 * corresponding components of Z are zero in this new basis. 00422 * 00423 K = 1 00424 K2 = N + 1 00425 DO 80 J = 2, N 00426 IF( ABS( Z( J ) ).LE.TOL ) THEN 00427 * 00428 * Deflate due to small z component. 00429 * 00430 K2 = K2 - 1 00431 IDXP( K2 ) = J 00432 COLTYP( J ) = 4 00433 IF( J.EQ.N ) 00434 $ GO TO 120 00435 ELSE 00436 JPREV = J 00437 GO TO 90 00438 END IF 00439 80 CONTINUE 00440 90 CONTINUE 00441 J = JPREV 00442 100 CONTINUE 00443 J = J + 1 00444 IF( J.GT.N ) 00445 $ GO TO 110 00446 IF( ABS( Z( J ) ).LE.TOL ) THEN 00447 * 00448 * Deflate due to small z component. 00449 * 00450 K2 = K2 - 1 00451 IDXP( K2 ) = J 00452 COLTYP( J ) = 4 00453 ELSE 00454 * 00455 * Check if singular values are close enough to allow deflation. 00456 * 00457 IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN 00458 * 00459 * Deflation is possible. 00460 * 00461 S = Z( JPREV ) 00462 C = Z( J ) 00463 * 00464 * Find sqrt(a**2+b**2) without overflow or 00465 * destructive underflow. 00466 * 00467 TAU = SLAPY2( C, S ) 00468 C = C / TAU 00469 S = -S / TAU 00470 Z( J ) = TAU 00471 Z( JPREV ) = ZERO 00472 * 00473 * Apply back the Givens rotation to the left and right 00474 * singular vector matrices. 00475 * 00476 IDXJP = IDXQ( IDX( JPREV )+1 ) 00477 IDXJ = IDXQ( IDX( J )+1 ) 00478 IF( IDXJP.LE.NLP1 ) THEN 00479 IDXJP = IDXJP - 1 00480 END IF 00481 IF( IDXJ.LE.NLP1 ) THEN 00482 IDXJ = IDXJ - 1 00483 END IF 00484 CALL SROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S ) 00485 CALL SROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C, 00486 $ S ) 00487 IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN 00488 COLTYP( J ) = 3 00489 END IF 00490 COLTYP( JPREV ) = 4 00491 K2 = K2 - 1 00492 IDXP( K2 ) = JPREV 00493 JPREV = J 00494 ELSE 00495 K = K + 1 00496 U2( K, 1 ) = Z( JPREV ) 00497 DSIGMA( K ) = D( JPREV ) 00498 IDXP( K ) = JPREV 00499 JPREV = J 00500 END IF 00501 END IF 00502 GO TO 100 00503 110 CONTINUE 00504 * 00505 * Record the last singular value. 00506 * 00507 K = K + 1 00508 U2( K, 1 ) = Z( JPREV ) 00509 DSIGMA( K ) = D( JPREV ) 00510 IDXP( K ) = JPREV 00511 * 00512 120 CONTINUE 00513 * 00514 * Count up the total number of the various types of columns, then 00515 * form a permutation which positions the four column types into 00516 * four groups of uniform structure (although one or more of these 00517 * groups may be empty). 00518 * 00519 DO 130 J = 1, 4 00520 CTOT( J ) = 0 00521 130 CONTINUE 00522 DO 140 J = 2, N 00523 CT = COLTYP( J ) 00524 CTOT( CT ) = CTOT( CT ) + 1 00525 140 CONTINUE 00526 * 00527 * PSM(*) = Position in SubMatrix (of types 1 through 4) 00528 * 00529 PSM( 1 ) = 2 00530 PSM( 2 ) = 2 + CTOT( 1 ) 00531 PSM( 3 ) = PSM( 2 ) + CTOT( 2 ) 00532 PSM( 4 ) = PSM( 3 ) + CTOT( 3 ) 00533 * 00534 * Fill out the IDXC array so that the permutation which it induces 00535 * will place all type-1 columns first, all type-2 columns next, 00536 * then all type-3's, and finally all type-4's, starting from the 00537 * second column. This applies similarly to the rows of VT. 00538 * 00539 DO 150 J = 2, N 00540 JP = IDXP( J ) 00541 CT = COLTYP( JP ) 00542 IDXC( PSM( CT ) ) = J 00543 PSM( CT ) = PSM( CT ) + 1 00544 150 CONTINUE 00545 * 00546 * Sort the singular values and corresponding singular vectors into 00547 * DSIGMA, U2, and VT2 respectively. The singular values/vectors 00548 * which were not deflated go into the first K slots of DSIGMA, U2, 00549 * and VT2 respectively, while those which were deflated go into the 00550 * last N - K slots, except that the first column/row will be treated 00551 * separately. 00552 * 00553 DO 160 J = 2, N 00554 JP = IDXP( J ) 00555 DSIGMA( J ) = D( JP ) 00556 IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 ) 00557 IF( IDXJ.LE.NLP1 ) THEN 00558 IDXJ = IDXJ - 1 00559 END IF 00560 CALL SCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 ) 00561 CALL SCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 ) 00562 160 CONTINUE 00563 * 00564 * Determine DSIGMA(1), DSIGMA(2) and Z(1) 00565 * 00566 DSIGMA( 1 ) = ZERO 00567 HLFTOL = TOL / TWO 00568 IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL ) 00569 $ DSIGMA( 2 ) = HLFTOL 00570 IF( M.GT.N ) THEN 00571 Z( 1 ) = SLAPY2( Z1, Z( M ) ) 00572 IF( Z( 1 ).LE.TOL ) THEN 00573 C = ONE 00574 S = ZERO 00575 Z( 1 ) = TOL 00576 ELSE 00577 C = Z1 / Z( 1 ) 00578 S = Z( M ) / Z( 1 ) 00579 END IF 00580 ELSE 00581 IF( ABS( Z1 ).LE.TOL ) THEN 00582 Z( 1 ) = TOL 00583 ELSE 00584 Z( 1 ) = Z1 00585 END IF 00586 END IF 00587 * 00588 * Move the rest of the updating row to Z. 00589 * 00590 CALL SCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 ) 00591 * 00592 * Determine the first column of U2, the first row of VT2 and the 00593 * last row of VT. 00594 * 00595 CALL SLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 ) 00596 U2( NLP1, 1 ) = ONE 00597 IF( M.GT.N ) THEN 00598 DO 170 I = 1, NLP1 00599 VT( M, I ) = -S*VT( NLP1, I ) 00600 VT2( 1, I ) = C*VT( NLP1, I ) 00601 170 CONTINUE 00602 DO 180 I = NLP2, M 00603 VT2( 1, I ) = S*VT( M, I ) 00604 VT( M, I ) = C*VT( M, I ) 00605 180 CONTINUE 00606 ELSE 00607 CALL SCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 ) 00608 END IF 00609 IF( M.GT.N ) THEN 00610 CALL SCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 ) 00611 END IF 00612 * 00613 * The deflated singular values and their corresponding vectors go 00614 * into the back of D, U, and V respectively. 00615 * 00616 IF( N.GT.K ) THEN 00617 CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 ) 00618 CALL SLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ), 00619 $ LDU ) 00620 CALL SLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ), 00621 $ LDVT ) 00622 END IF 00623 * 00624 * Copy CTOT into COLTYP for referencing in SLASD3. 00625 * 00626 DO 190 J = 1, 4 00627 COLTYP( J ) = CTOT( J ) 00628 190 CONTINUE 00629 * 00630 RETURN 00631 * 00632 * End of SLASD2 00633 * 00634 END