 |
LAPACK
3.4.0
LAPACK: Linear Algebra PACKage
|
|
LAPACK
3.4.0
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SGSVJ1 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download SGSVJ1 + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgsvj1.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgsvj1.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgsvj1.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, 00022 * EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) 00023 * 00024 * .. Scalar Arguments .. 00025 * REAL EPS, SFMIN, TOL 00026 * INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP 00027 * CHARACTER*1 JOBV 00028 * .. 00029 * .. Array Arguments .. 00030 * REAL A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), 00031 * $ WORK( LWORK ) 00032 * .. 00033 * 00034 * 00035 *> \par Purpose: 00036 * ============= 00037 *> 00038 *> \verbatim 00039 *> 00040 *> SGSVJ1 is called from SGESVJ as a pre-processor and that is its main 00041 *> purpose. It applies Jacobi rotations in the same way as SGESVJ does, but 00042 *> it targets only particular pivots and it does not check convergence 00043 *> (stopping criterion). Few tunning parameters (marked by [TP]) are 00044 *> available for the implementer. 00045 *> 00046 *> Further Details 00047 *> ~~~~~~~~~~~~~~~ 00048 *> SGSVJ1 applies few sweeps of Jacobi rotations in the column space of 00049 *> the input M-by-N matrix A. The pivot pairs are taken from the (1,2) 00050 *> off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The 00051 *> block-entries (tiles) of the (1,2) off-diagonal block are marked by the 00052 *> [x]'s in the following scheme: 00053 *> 00054 *> | * * * [x] [x] [x]| 00055 *> | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. 00056 *> | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. 00057 *> |[x] [x] [x] * * * | 00058 *> |[x] [x] [x] * * * | 00059 *> |[x] [x] [x] * * * | 00060 *> 00061 *> In terms of the columns of A, the first N1 columns are rotated 'against' 00062 *> the remaining N-N1 columns, trying to increase the angle between the 00063 *> corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is 00064 *> tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter. 00065 *> The number of sweeps is given in NSWEEP and the orthogonality threshold 00066 *> is given in TOL. 00067 *> \endverbatim 00068 * 00069 * Arguments: 00070 * ========== 00071 * 00072 *> \param[in] JOBV 00073 *> \verbatim 00074 *> JOBV is CHARACTER*1 00075 *> Specifies whether the output from this procedure is used 00076 *> to compute the matrix V: 00077 *> = 'V': the product of the Jacobi rotations is accumulated 00078 *> by postmulyiplying the N-by-N array V. 00079 *> (See the description of V.) 00080 *> = 'A': the product of the Jacobi rotations is accumulated 00081 *> by postmulyiplying the MV-by-N array V. 00082 *> (See the descriptions of MV and V.) 00083 *> = 'N': the Jacobi rotations are not accumulated. 00084 *> \endverbatim 00085 *> 00086 *> \param[in] M 00087 *> \verbatim 00088 *> M is INTEGER 00089 *> The number of rows of the input matrix A. M >= 0. 00090 *> \endverbatim 00091 *> 00092 *> \param[in] N 00093 *> \verbatim 00094 *> N is INTEGER 00095 *> The number of columns of the input matrix A. 00096 *> M >= N >= 0. 00097 *> \endverbatim 00098 *> 00099 *> \param[in] N1 00100 *> \verbatim 00101 *> N1 is INTEGER 00102 *> N1 specifies the 2 x 2 block partition, the first N1 columns are 00103 *> rotated 'against' the remaining N-N1 columns of A. 00104 *> \endverbatim 00105 *> 00106 *> \param[in,out] A 00107 *> \verbatim 00108 *> A is REAL array, dimension (LDA,N) 00109 *> On entry, M-by-N matrix A, such that A*diag(D) represents 00110 *> the input matrix. 00111 *> On exit, 00112 *> A_onexit * D_onexit represents the input matrix A*diag(D) 00113 *> post-multiplied by a sequence of Jacobi rotations, where the 00114 *> rotation threshold and the total number of sweeps are given in 00115 *> TOL and NSWEEP, respectively. 00116 *> (See the descriptions of N1, D, TOL and NSWEEP.) 00117 *> \endverbatim 00118 *> 00119 *> \param[in] LDA 00120 *> \verbatim 00121 *> LDA is INTEGER 00122 *> The leading dimension of the array A. LDA >= max(1,M). 00123 *> \endverbatim 00124 *> 00125 *> \param[in,out] D 00126 *> \verbatim 00127 *> D is REAL array, dimension (N) 00128 *> The array D accumulates the scaling factors from the fast scaled 00129 *> Jacobi rotations. 00130 *> On entry, A*diag(D) represents the input matrix. 00131 *> On exit, A_onexit*diag(D_onexit) represents the input matrix 00132 *> post-multiplied by a sequence of Jacobi rotations, where the 00133 *> rotation threshold and the total number of sweeps are given in 00134 *> TOL and NSWEEP, respectively. 00135 *> (See the descriptions of N1, A, TOL and NSWEEP.) 00136 *> \endverbatim 00137 *> 00138 *> \param[in,out] SVA 00139 *> \verbatim 00140 *> SVA is REAL array, dimension (N) 00141 *> On entry, SVA contains the Euclidean norms of the columns of 00142 *> the matrix A*diag(D). 00143 *> On exit, SVA contains the Euclidean norms of the columns of 00144 *> the matrix onexit*diag(D_onexit). 00145 *> \endverbatim 00146 *> 00147 *> \param[in] MV 00148 *> \verbatim 00149 *> MV is INTEGER 00150 *> If JOBV .EQ. 'A', then MV rows of V are post-multipled by a 00151 *> sequence of Jacobi rotations. 00152 *> If JOBV = 'N', then MV is not referenced. 00153 *> \endverbatim 00154 *> 00155 *> \param[in,out] V 00156 *> \verbatim 00157 *> V is REAL array, dimension (LDV,N) 00158 *> If JOBV .EQ. 'V' then N rows of V are post-multipled by a 00159 *> sequence of Jacobi rotations. 00160 *> If JOBV .EQ. 'A' then MV rows of V are post-multipled by a 00161 *> sequence of Jacobi rotations. 00162 *> If JOBV = 'N', then V is not referenced. 00163 *> \endverbatim 00164 *> 00165 *> \param[in] LDV 00166 *> \verbatim 00167 *> LDV is INTEGER 00168 *> The leading dimension of the array V, LDV >= 1. 00169 *> If JOBV = 'V', LDV .GE. N. 00170 *> If JOBV = 'A', LDV .GE. MV. 00171 *> \endverbatim 00172 *> 00173 *> \param[in] EPS 00174 *> \verbatim 00175 *> EPS is INTEGER 00176 *> EPS = SLAMCH('Epsilon') 00177 *> \endverbatim 00178 *> 00179 *> \param[in] SFMIN 00180 *> \verbatim 00181 *> SFMIN is INTEGER 00182 *> SFMIN = SLAMCH('Safe Minimum') 00183 *> \endverbatim 00184 *> 00185 *> \param[in] TOL 00186 *> \verbatim 00187 *> TOL is REAL 00188 *> TOL is the threshold for Jacobi rotations. For a pair 00189 *> A(:,p), A(:,q) of pivot columns, the Jacobi rotation is 00190 *> applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. 00191 *> \endverbatim 00192 *> 00193 *> \param[in] NSWEEP 00194 *> \verbatim 00195 *> NSWEEP is INTEGER 00196 *> NSWEEP is the number of sweeps of Jacobi rotations to be 00197 *> performed. 00198 *> \endverbatim 00199 *> 00200 *> \param[out] WORK 00201 *> \verbatim 00202 *> WORK is REAL array, dimension LWORK. 00203 *> \endverbatim 00204 *> 00205 *> \param[in] LWORK 00206 *> \verbatim 00207 *> LWORK is INTEGER 00208 *> LWORK is the dimension of WORK. LWORK .GE. M. 00209 *> \endverbatim 00210 *> 00211 *> \param[out] INFO 00212 *> \verbatim 00213 *> INFO is INTEGER 00214 *> = 0 : successful exit. 00215 *> < 0 : if INFO = -i, then the i-th argument had an illegal value 00216 *> \endverbatim 00217 * 00218 * Authors: 00219 * ======== 00220 * 00221 *> \author Univ. of Tennessee 00222 *> \author Univ. of California Berkeley 00223 *> \author Univ. of Colorado Denver 00224 *> \author NAG Ltd. 00225 * 00226 *> \date November 2011 00227 * 00228 *> \ingroup realOTHERcomputational 00229 * 00230 *> \par Contributors: 00231 * ================== 00232 *> 00233 *> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) 00234 * 00235 * ===================================================================== 00236 SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, 00237 $ EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) 00238 * 00239 * -- LAPACK computational routine (version 3.4.0) -- 00240 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00241 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00242 * November 2011 00243 * 00244 * .. Scalar Arguments .. 00245 REAL EPS, SFMIN, TOL 00246 INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP 00247 CHARACTER*1 JOBV 00248 * .. 00249 * .. Array Arguments .. 00250 REAL A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), 00251 $ WORK( LWORK ) 00252 * .. 00253 * 00254 * ===================================================================== 00255 * 00256 * .. Local Parameters .. 00257 REAL ZERO, HALF, ONE, TWO 00258 PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, 00259 $ TWO = 2.0E0 ) 00260 * .. 00261 * .. Local Scalars .. 00262 REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, 00263 $ BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG, 00264 $ ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T, 00265 $ TEMP1, THETA, THSIGN 00266 INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, 00267 $ ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr, 00268 $ p, PSKIPPED, q, ROWSKIP, SWBAND 00269 LOGICAL APPLV, ROTOK, RSVEC 00270 * .. 00271 * .. Local Arrays .. 00272 REAL FASTR( 5 ) 00273 * .. 00274 * .. Intrinsic Functions .. 00275 INTRINSIC ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT 00276 * .. 00277 * .. External Functions .. 00278 REAL SDOT, SNRM2 00279 INTEGER ISAMAX 00280 LOGICAL LSAME 00281 EXTERNAL ISAMAX, LSAME, SDOT, SNRM2 00282 * .. 00283 * .. External Subroutines .. 00284 EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP 00285 * .. 00286 * .. Executable Statements .. 00287 * 00288 * Test the input parameters. 00289 * 00290 APPLV = LSAME( JOBV, 'A' ) 00291 RSVEC = LSAME( JOBV, 'V' ) 00292 IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN 00293 INFO = -1 00294 ELSE IF( M.LT.0 ) THEN 00295 INFO = -2 00296 ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN 00297 INFO = -3 00298 ELSE IF( N1.LT.0 ) THEN 00299 INFO = -4 00300 ELSE IF( LDA.LT.M ) THEN 00301 INFO = -6 00302 ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN 00303 INFO = -9 00304 ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. 00305 $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN 00306 INFO = -11 00307 ELSE IF( TOL.LE.EPS ) THEN 00308 INFO = -14 00309 ELSE IF( NSWEEP.LT.0 ) THEN 00310 INFO = -15 00311 ELSE IF( LWORK.LT.M ) THEN 00312 INFO = -17 00313 ELSE 00314 INFO = 0 00315 END IF 00316 * 00317 * #:( 00318 IF( INFO.NE.0 ) THEN 00319 CALL XERBLA( 'SGSVJ1', -INFO ) 00320 RETURN 00321 END IF 00322 * 00323 IF( RSVEC ) THEN 00324 MVL = N 00325 ELSE IF( APPLV ) THEN 00326 MVL = MV 00327 END IF 00328 RSVEC = RSVEC .OR. APPLV 00329 00330 ROOTEPS = SQRT( EPS ) 00331 ROOTSFMIN = SQRT( SFMIN ) 00332 SMALL = SFMIN / EPS 00333 BIG = ONE / SFMIN 00334 ROOTBIG = ONE / ROOTSFMIN 00335 LARGE = BIG / SQRT( FLOAT( M*N ) ) 00336 BIGTHETA = ONE / ROOTEPS 00337 ROOTTOL = SQRT( TOL ) 00338 * 00339 * .. Initialize the right singular vector matrix .. 00340 * 00341 * RSVEC = LSAME( JOBV, 'Y' ) 00342 * 00343 EMPTSW = N1*( N-N1 ) 00344 NOTROT = 0 00345 FASTR( 1 ) = ZERO 00346 * 00347 * .. Row-cyclic pivot strategy with de Rijk's pivoting .. 00348 * 00349 KBL = MIN0( 8, N ) 00350 NBLR = N1 / KBL 00351 IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1 00352 00353 * .. the tiling is nblr-by-nblc [tiles] 00354 00355 NBLC = ( N-N1 ) / KBL 00356 IF( ( NBLC*KBL ).NE.( N-N1 ) )NBLC = NBLC + 1 00357 BLSKIP = ( KBL**2 ) + 1 00358 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. 00359 00360 ROWSKIP = MIN0( 5, KBL ) 00361 *[TP] ROWSKIP is a tuning parameter. 00362 SWBAND = 0 00363 *[TP] SWBAND is a tuning parameter. It is meaningful and effective 00364 * if SGESVJ is used as a computational routine in the preconditioned 00365 * Jacobi SVD algorithm SGESVJ. 00366 * 00367 * 00368 * | * * * [x] [x] [x]| 00369 * | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. 00370 * | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. 00371 * |[x] [x] [x] * * * | 00372 * |[x] [x] [x] * * * | 00373 * |[x] [x] [x] * * * | 00374 * 00375 * 00376 DO 1993 i = 1, NSWEEP 00377 * .. go go go ... 00378 * 00379 MXAAPQ = ZERO 00380 MXSINJ = ZERO 00381 ISWROT = 0 00382 * 00383 NOTROT = 0 00384 PSKIPPED = 0 00385 * 00386 DO 2000 ibr = 1, NBLR 00387 00388 igl = ( ibr-1 )*KBL + 1 00389 * 00390 * 00391 *........................................................ 00392 * ... go to the off diagonal blocks 00393 00394 igl = ( ibr-1 )*KBL + 1 00395 00396 DO 2010 jbc = 1, NBLC 00397 00398 jgl = N1 + ( jbc-1 )*KBL + 1 00399 00400 * doing the block at ( ibr, jbc ) 00401 00402 IJBLSK = 0 00403 DO 2100 p = igl, MIN0( igl+KBL-1, N1 ) 00404 00405 AAPP = SVA( p ) 00406 00407 IF( AAPP.GT.ZERO ) THEN 00408 00409 PSKIPPED = 0 00410 00411 DO 2200 q = jgl, MIN0( jgl+KBL-1, N ) 00412 * 00413 AAQQ = SVA( q ) 00414 00415 IF( AAQQ.GT.ZERO ) THEN 00416 AAPP0 = AAPP 00417 * 00418 * .. M x 2 Jacobi SVD .. 00419 * 00420 * .. Safe Gram matrix computation .. 00421 * 00422 IF( AAQQ.GE.ONE ) THEN 00423 IF( AAPP.GE.AAQQ ) THEN 00424 ROTOK = ( SMALL*AAPP ).LE.AAQQ 00425 ELSE 00426 ROTOK = ( SMALL*AAQQ ).LE.AAPP 00427 END IF 00428 IF( AAPP.LT.( BIG / AAQQ ) ) THEN 00429 AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1, 00430 $ q ), 1 )*D( p )*D( q ) / AAQQ ) 00431 $ / AAPP 00432 ELSE 00433 CALL SCOPY( M, A( 1, p ), 1, WORK, 1 ) 00434 CALL SLASCL( 'G', 0, 0, AAPP, D( p ), 00435 $ M, 1, WORK, LDA, IERR ) 00436 AAPQ = SDOT( M, WORK, 1, A( 1, q ), 00437 $ 1 )*D( q ) / AAQQ 00438 END IF 00439 ELSE 00440 IF( AAPP.GE.AAQQ ) THEN 00441 ROTOK = AAPP.LE.( AAQQ / SMALL ) 00442 ELSE 00443 ROTOK = AAQQ.LE.( AAPP / SMALL ) 00444 END IF 00445 IF( AAPP.GT.( SMALL / AAQQ ) ) THEN 00446 AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1, 00447 $ q ), 1 )*D( p )*D( q ) / AAQQ ) 00448 $ / AAPP 00449 ELSE 00450 CALL SCOPY( M, A( 1, q ), 1, WORK, 1 ) 00451 CALL SLASCL( 'G', 0, 0, AAQQ, D( q ), 00452 $ M, 1, WORK, LDA, IERR ) 00453 AAPQ = SDOT( M, WORK, 1, A( 1, p ), 00454 $ 1 )*D( p ) / AAPP 00455 END IF 00456 END IF 00457 00458 MXAAPQ = AMAX1( MXAAPQ, ABS( AAPQ ) ) 00459 00460 * TO rotate or NOT to rotate, THAT is the question ... 00461 * 00462 IF( ABS( AAPQ ).GT.TOL ) THEN 00463 NOTROT = 0 00464 * ROTATED = ROTATED + 1 00465 PSKIPPED = 0 00466 ISWROT = ISWROT + 1 00467 * 00468 IF( ROTOK ) THEN 00469 * 00470 AQOAP = AAQQ / AAPP 00471 APOAQ = AAPP / AAQQ 00472 THETA = -HALF*ABS( AQOAP-APOAQ ) / AAPQ 00473 IF( AAQQ.GT.AAPP0 )THETA = -THETA 00474 00475 IF( ABS( THETA ).GT.BIGTHETA ) THEN 00476 T = HALF / THETA 00477 FASTR( 3 ) = T*D( p ) / D( q ) 00478 FASTR( 4 ) = -T*D( q ) / D( p ) 00479 CALL SROTM( M, A( 1, p ), 1, 00480 $ A( 1, q ), 1, FASTR ) 00481 IF( RSVEC )CALL SROTM( MVL, 00482 $ V( 1, p ), 1, 00483 $ V( 1, q ), 1, 00484 $ FASTR ) 00485 SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, 00486 $ ONE+T*APOAQ*AAPQ ) ) 00487 AAPP = AAPP*SQRT( AMAX1( ZERO, 00488 $ ONE-T*AQOAP*AAPQ ) ) 00489 MXSINJ = AMAX1( MXSINJ, ABS( T ) ) 00490 ELSE 00491 * 00492 * .. choose correct signum for THETA and rotate 00493 * 00494 THSIGN = -SIGN( ONE, AAPQ ) 00495 IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN 00496 T = ONE / ( THETA+THSIGN* 00497 $ SQRT( ONE+THETA*THETA ) ) 00498 CS = SQRT( ONE / ( ONE+T*T ) ) 00499 SN = T*CS 00500 MXSINJ = AMAX1( MXSINJ, ABS( SN ) ) 00501 SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, 00502 $ ONE+T*APOAQ*AAPQ ) ) 00503 AAPP = AAPP*SQRT( AMAX1( ZERO, 00504 $ ONE-T*AQOAP*AAPQ ) ) 00505 00506 APOAQ = D( p ) / D( q ) 00507 AQOAP = D( q ) / D( p ) 00508 IF( D( p ).GE.ONE ) THEN 00509 * 00510 IF( D( q ).GE.ONE ) THEN 00511 FASTR( 3 ) = T*APOAQ 00512 FASTR( 4 ) = -T*AQOAP 00513 D( p ) = D( p )*CS 00514 D( q ) = D( q )*CS 00515 CALL SROTM( M, A( 1, p ), 1, 00516 $ A( 1, q ), 1, 00517 $ FASTR ) 00518 IF( RSVEC )CALL SROTM( MVL, 00519 $ V( 1, p ), 1, V( 1, q ), 00520 $ 1, FASTR ) 00521 ELSE 00522 CALL SAXPY( M, -T*AQOAP, 00523 $ A( 1, q ), 1, 00524 $ A( 1, p ), 1 ) 00525 CALL SAXPY( M, CS*SN*APOAQ, 00526 $ A( 1, p ), 1, 00527 $ A( 1, q ), 1 ) 00528 IF( RSVEC ) THEN 00529 CALL SAXPY( MVL, -T*AQOAP, 00530 $ V( 1, q ), 1, 00531 $ V( 1, p ), 1 ) 00532 CALL SAXPY( MVL, 00533 $ CS*SN*APOAQ, 00534 $ V( 1, p ), 1, 00535 $ V( 1, q ), 1 ) 00536 END IF 00537 D( p ) = D( p )*CS 00538 D( q ) = D( q ) / CS 00539 END IF 00540 ELSE 00541 IF( D( q ).GE.ONE ) THEN 00542 CALL SAXPY( M, T*APOAQ, 00543 $ A( 1, p ), 1, 00544 $ A( 1, q ), 1 ) 00545 CALL SAXPY( M, -CS*SN*AQOAP, 00546 $ A( 1, q ), 1, 00547 $ A( 1, p ), 1 ) 00548 IF( RSVEC ) THEN 00549 CALL SAXPY( MVL, T*APOAQ, 00550 $ V( 1, p ), 1, 00551 $ V( 1, q ), 1 ) 00552 CALL SAXPY( MVL, 00553 $ -CS*SN*AQOAP, 00554 $ V( 1, q ), 1, 00555 $ V( 1, p ), 1 ) 00556 END IF 00557 D( p ) = D( p ) / CS 00558 D( q ) = D( q )*CS 00559 ELSE 00560 IF( D( p ).GE.D( q ) ) THEN 00561 CALL SAXPY( M, -T*AQOAP, 00562 $ A( 1, q ), 1, 00563 $ A( 1, p ), 1 ) 00564 CALL SAXPY( M, CS*SN*APOAQ, 00565 $ A( 1, p ), 1, 00566 $ A( 1, q ), 1 ) 00567 D( p ) = D( p )*CS 00568 D( q ) = D( q ) / CS 00569 IF( RSVEC ) THEN 00570 CALL SAXPY( MVL, 00571 $ -T*AQOAP, 00572 $ V( 1, q ), 1, 00573 $ V( 1, p ), 1 ) 00574 CALL SAXPY( MVL, 00575 $ CS*SN*APOAQ, 00576 $ V( 1, p ), 1, 00577 $ V( 1, q ), 1 ) 00578 END IF 00579 ELSE 00580 CALL SAXPY( M, T*APOAQ, 00581 $ A( 1, p ), 1, 00582 $ A( 1, q ), 1 ) 00583 CALL SAXPY( M, 00584 $ -CS*SN*AQOAP, 00585 $ A( 1, q ), 1, 00586 $ A( 1, p ), 1 ) 00587 D( p ) = D( p ) / CS 00588 D( q ) = D( q )*CS 00589 IF( RSVEC ) THEN 00590 CALL SAXPY( MVL, 00591 $ T*APOAQ, V( 1, p ), 00592 $ 1, V( 1, q ), 1 ) 00593 CALL SAXPY( MVL, 00594 $ -CS*SN*AQOAP, 00595 $ V( 1, q ), 1, 00596 $ V( 1, p ), 1 ) 00597 END IF 00598 END IF 00599 END IF 00600 END IF 00601 END IF 00602 00603 ELSE 00604 IF( AAPP.GT.AAQQ ) THEN 00605 CALL SCOPY( M, A( 1, p ), 1, WORK, 00606 $ 1 ) 00607 CALL SLASCL( 'G', 0, 0, AAPP, ONE, 00608 $ M, 1, WORK, LDA, IERR ) 00609 CALL SLASCL( 'G', 0, 0, AAQQ, ONE, 00610 $ M, 1, A( 1, q ), LDA, 00611 $ IERR ) 00612 TEMP1 = -AAPQ*D( p ) / D( q ) 00613 CALL SAXPY( M, TEMP1, WORK, 1, 00614 $ A( 1, q ), 1 ) 00615 CALL SLASCL( 'G', 0, 0, ONE, AAQQ, 00616 $ M, 1, A( 1, q ), LDA, 00617 $ IERR ) 00618 SVA( q ) = AAQQ*SQRT( AMAX1( ZERO, 00619 $ ONE-AAPQ*AAPQ ) ) 00620 MXSINJ = AMAX1( MXSINJ, SFMIN ) 00621 ELSE 00622 CALL SCOPY( M, A( 1, q ), 1, WORK, 00623 $ 1 ) 00624 CALL SLASCL( 'G', 0, 0, AAQQ, ONE, 00625 $ M, 1, WORK, LDA, IERR ) 00626 CALL SLASCL( 'G', 0, 0, AAPP, ONE, 00627 $ M, 1, A( 1, p ), LDA, 00628 $ IERR ) 00629 TEMP1 = -AAPQ*D( q ) / D( p ) 00630 CALL SAXPY( M, TEMP1, WORK, 1, 00631 $ A( 1, p ), 1 ) 00632 CALL SLASCL( 'G', 0, 0, ONE, AAPP, 00633 $ M, 1, A( 1, p ), LDA, 00634 $ IERR ) 00635 SVA( p ) = AAPP*SQRT( AMAX1( ZERO, 00636 $ ONE-AAPQ*AAPQ ) ) 00637 MXSINJ = AMAX1( MXSINJ, SFMIN ) 00638 END IF 00639 END IF 00640 * END IF ROTOK THEN ... ELSE 00641 * 00642 * In the case of cancellation in updating SVA(q) 00643 * .. recompute SVA(q) 00644 IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) 00645 $ THEN 00646 IF( ( AAQQ.LT.ROOTBIG ) .AND. 00647 $ ( AAQQ.GT.ROOTSFMIN ) ) THEN 00648 SVA( q ) = SNRM2( M, A( 1, q ), 1 )* 00649 $ D( q ) 00650 ELSE 00651 T = ZERO 00652 AAQQ = ONE 00653 CALL SLASSQ( M, A( 1, q ), 1, T, 00654 $ AAQQ ) 00655 SVA( q ) = T*SQRT( AAQQ )*D( q ) 00656 END IF 00657 END IF 00658 IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN 00659 IF( ( AAPP.LT.ROOTBIG ) .AND. 00660 $ ( AAPP.GT.ROOTSFMIN ) ) THEN 00661 AAPP = SNRM2( M, A( 1, p ), 1 )* 00662 $ D( p ) 00663 ELSE 00664 T = ZERO 00665 AAPP = ONE 00666 CALL SLASSQ( M, A( 1, p ), 1, T, 00667 $ AAPP ) 00668 AAPP = T*SQRT( AAPP )*D( p ) 00669 END IF 00670 SVA( p ) = AAPP 00671 END IF 00672 * end of OK rotation 00673 ELSE 00674 NOTROT = NOTROT + 1 00675 * SKIPPED = SKIPPED + 1 00676 PSKIPPED = PSKIPPED + 1 00677 IJBLSK = IJBLSK + 1 00678 END IF 00679 ELSE 00680 NOTROT = NOTROT + 1 00681 PSKIPPED = PSKIPPED + 1 00682 IJBLSK = IJBLSK + 1 00683 END IF 00684 00685 * IF ( NOTROT .GE. EMPTSW ) GO TO 2011 00686 IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) ) 00687 $ THEN 00688 SVA( p ) = AAPP 00689 NOTROT = 0 00690 GO TO 2011 00691 END IF 00692 IF( ( i.LE.SWBAND ) .AND. 00693 $ ( PSKIPPED.GT.ROWSKIP ) ) THEN 00694 AAPP = -AAPP 00695 NOTROT = 0 00696 GO TO 2203 00697 END IF 00698 00699 * 00700 2200 CONTINUE 00701 * end of the q-loop 00702 2203 CONTINUE 00703 00704 SVA( p ) = AAPP 00705 * 00706 ELSE 00707 IF( AAPP.EQ.ZERO )NOTROT = NOTROT + 00708 $ MIN0( jgl+KBL-1, N ) - jgl + 1 00709 IF( AAPP.LT.ZERO )NOTROT = 0 00710 *** IF ( NOTROT .GE. EMPTSW ) GO TO 2011 00711 END IF 00712 00713 2100 CONTINUE 00714 * end of the p-loop 00715 2010 CONTINUE 00716 * end of the jbc-loop 00717 2011 CONTINUE 00718 *2011 bailed out of the jbc-loop 00719 DO 2012 p = igl, MIN0( igl+KBL-1, N ) 00720 SVA( p ) = ABS( SVA( p ) ) 00721 2012 CONTINUE 00722 *** IF ( NOTROT .GE. EMPTSW ) GO TO 1994 00723 2000 CONTINUE 00724 *2000 :: end of the ibr-loop 00725 * 00726 * .. update SVA(N) 00727 IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) ) 00728 $ THEN 00729 SVA( N ) = SNRM2( M, A( 1, N ), 1 )*D( N ) 00730 ELSE 00731 T = ZERO 00732 AAPP = ONE 00733 CALL SLASSQ( M, A( 1, N ), 1, T, AAPP ) 00734 SVA( N ) = T*SQRT( AAPP )*D( N ) 00735 END IF 00736 * 00737 * Additional steering devices 00738 * 00739 IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. 00740 $ ( ISWROT.LE.N ) ) )SWBAND = i 00741 00742 IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.FLOAT( N )*TOL ) .AND. 00743 $ ( FLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN 00744 GO TO 1994 00745 END IF 00746 00747 * 00748 IF( NOTROT.GE.EMPTSW )GO TO 1994 00749 00750 1993 CONTINUE 00751 * end i=1:NSWEEP loop 00752 * #:) Reaching this point means that the procedure has completed the given 00753 * number of sweeps. 00754 INFO = NSWEEP - 1 00755 GO TO 1995 00756 1994 CONTINUE 00757 * #:) Reaching this point means that during the i-th sweep all pivots were 00758 * below the given threshold, causing early exit. 00759 00760 INFO = 0 00761 * #:) INFO = 0 confirms successful iterations. 00762 1995 CONTINUE 00763 * 00764 * Sort the vector D 00765 * 00766 DO 5991 p = 1, N - 1 00767 q = ISAMAX( N-p+1, SVA( p ), 1 ) + p - 1 00768 IF( p.NE.q ) THEN 00769 TEMP1 = SVA( p ) 00770 SVA( p ) = SVA( q ) 00771 SVA( q ) = TEMP1 00772 TEMP1 = D( p ) 00773 D( p ) = D( q ) 00774 D( q ) = TEMP1 00775 CALL SSWAP( M, A( 1, p ), 1, A( 1, q ), 1 ) 00776 IF( RSVEC )CALL SSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 ) 00777 END IF 00778 5991 CONTINUE 00779 * 00780 RETURN 00781 * .. 00782 * .. END OF SGSVJ1 00783 * .. 00784 END
1.7.6.1 
