 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE SLAVSY( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, 00002 $ LDB, INFO ) 00003 * 00004 * -- LAPACK auxiliary routine (version 3.1) -- 00005 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 CHARACTER DIAG, TRANS, UPLO 00010 INTEGER INFO, LDA, LDB, N, NRHS 00011 * .. 00012 * .. Array Arguments .. 00013 INTEGER IPIV( * ) 00014 REAL A( LDA, * ), B( LDB, * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * SLAVSY performs one of the matrix-vector operations 00021 * x := A*x or x := A'*x, 00022 * where x is an N element vector and A is one of the factors 00023 * from the block U*D*U' or L*D*L' factorization computed by SSYTRF. 00024 * 00025 * If TRANS = 'N', multiplies by U or U * D (or L or L * D) 00026 * If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') 00027 * If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') 00028 * 00029 * Arguments 00030 * ========= 00031 * 00032 * UPLO (input) CHARACTER*1 00033 * Specifies whether the factor stored in A is upper or lower 00034 * triangular. 00035 * = 'U': Upper triangular 00036 * = 'L': Lower triangular 00037 * 00038 * TRANS (input) CHARACTER*1 00039 * Specifies the operation to be performed: 00040 * = 'N': x := A*x 00041 * = 'T': x := A'*x 00042 * = 'C': x := A'*x 00043 * 00044 * DIAG (input) CHARACTER*1 00045 * Specifies whether or not the diagonal blocks are unit 00046 * matrices. If the diagonal blocks are assumed to be unit, 00047 * then A = U or A = L, otherwise A = U*D or A = L*D. 00048 * = 'U': Diagonal blocks are assumed to be unit matrices. 00049 * = 'N': Diagonal blocks are assumed to be non-unit matrices. 00050 * 00051 * N (input) INTEGER 00052 * The number of rows and columns of the matrix A. N >= 0. 00053 * 00054 * NRHS (input) INTEGER 00055 * The number of right hand sides, i.e., the number of vectors 00056 * x to be multiplied by A. NRHS >= 0. 00057 * 00058 * A (input) REAL array, dimension (LDA,N) 00059 * The block diagonal matrix D and the multipliers used to 00060 * obtain the factor U or L as computed by SSYTRF. 00061 * 00062 * LDA (input) INTEGER 00063 * The leading dimension of the array A. LDA >= max(1,N). 00064 * 00065 * IPIV (input) INTEGER array, dimension (N) 00066 * The pivot indices from SSYTRF. 00067 * 00068 * B (input/output) REAL array, dimension (LDB,NRHS) 00069 * On entry, B contains NRHS vectors of length N. 00070 * On exit, B is overwritten with the product A * B. 00071 * 00072 * LDB (input) INTEGER 00073 * The leading dimension of the array B. LDB >= max(1,N). 00074 * 00075 * INFO (output) INTEGER 00076 * = 0: successful exit 00077 * < 0: if INFO = -k, the k-th argument had an illegal value 00078 * 00079 * ===================================================================== 00080 * 00081 * .. Parameters .. 00082 REAL ONE 00083 PARAMETER ( ONE = 1.0E+0 ) 00084 * .. 00085 * .. Local Scalars .. 00086 LOGICAL NOUNIT 00087 INTEGER J, K, KP 00088 REAL D11, D12, D21, D22, T1, T2 00089 * .. 00090 * .. External Functions .. 00091 LOGICAL LSAME 00092 EXTERNAL LSAME 00093 * .. 00094 * .. External Subroutines .. 00095 EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA 00096 * .. 00097 * .. Intrinsic Functions .. 00098 INTRINSIC ABS, MAX 00099 * .. 00100 * .. Executable Statements .. 00101 * 00102 * Test the input parameters. 00103 * 00104 INFO = 0 00105 IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 00106 INFO = -1 00107 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. 00108 $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 00109 INFO = -2 00110 ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) ) 00111 $ THEN 00112 INFO = -3 00113 ELSE IF( N.LT.0 ) THEN 00114 INFO = -4 00115 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN 00116 INFO = -6 00117 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN 00118 INFO = -9 00119 END IF 00120 IF( INFO.NE.0 ) THEN 00121 CALL XERBLA( 'SLAVSY ', -INFO ) 00122 RETURN 00123 END IF 00124 * 00125 * Quick return if possible. 00126 * 00127 IF( N.EQ.0 ) 00128 $ RETURN 00129 * 00130 NOUNIT = LSAME( DIAG, 'N' ) 00131 *------------------------------------------ 00132 * 00133 * Compute B := A * B (No transpose) 00134 * 00135 *------------------------------------------ 00136 IF( LSAME( TRANS, 'N' ) ) THEN 00137 * 00138 * Compute B := U*B 00139 * where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) 00140 * 00141 IF( LSAME( UPLO, 'U' ) ) THEN 00142 * 00143 * Loop forward applying the transformations. 00144 * 00145 K = 1 00146 10 CONTINUE 00147 IF( K.GT.N ) 00148 $ GO TO 30 00149 IF( IPIV( K ).GT.0 ) THEN 00150 * 00151 * 1 x 1 pivot block 00152 * 00153 * Multiply by the diagonal element if forming U * D. 00154 * 00155 IF( NOUNIT ) 00156 $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) 00157 * 00158 * Multiply by P(K) * inv(U(K)) if K > 1. 00159 * 00160 IF( K.GT.1 ) THEN 00161 * 00162 * Apply the transformation. 00163 * 00164 CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ), 00165 $ LDB, B( 1, 1 ), LDB ) 00166 * 00167 * Interchange if P(K) .ne. I. 00168 * 00169 KP = IPIV( K ) 00170 IF( KP.NE.K ) 00171 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 00172 END IF 00173 K = K + 1 00174 ELSE 00175 * 00176 * 2 x 2 pivot block 00177 * 00178 * Multiply by the diagonal block if forming U * D. 00179 * 00180 IF( NOUNIT ) THEN 00181 D11 = A( K, K ) 00182 D22 = A( K+1, K+1 ) 00183 D12 = A( K, K+1 ) 00184 D21 = D12 00185 DO 20 J = 1, NRHS 00186 T1 = B( K, J ) 00187 T2 = B( K+1, J ) 00188 B( K, J ) = D11*T1 + D12*T2 00189 B( K+1, J ) = D21*T1 + D22*T2 00190 20 CONTINUE 00191 END IF 00192 * 00193 * Multiply by P(K) * inv(U(K)) if K > 1. 00194 * 00195 IF( K.GT.1 ) THEN 00196 * 00197 * Apply the transformations. 00198 * 00199 CALL SGER( K-1, NRHS, ONE, A( 1, K ), 1, B( K, 1 ), 00200 $ LDB, B( 1, 1 ), LDB ) 00201 CALL SGER( K-1, NRHS, ONE, A( 1, K+1 ), 1, 00202 $ B( K+1, 1 ), LDB, B( 1, 1 ), LDB ) 00203 * 00204 * Interchange if P(K) .ne. I. 00205 * 00206 KP = ABS( IPIV( K ) ) 00207 IF( KP.NE.K ) 00208 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 00209 END IF 00210 K = K + 2 00211 END IF 00212 GO TO 10 00213 30 CONTINUE 00214 * 00215 * Compute B := L*B 00216 * where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . 00217 * 00218 ELSE 00219 * 00220 * Loop backward applying the transformations to B. 00221 * 00222 K = N 00223 40 CONTINUE 00224 IF( K.LT.1 ) 00225 $ GO TO 60 00226 * 00227 * Test the pivot index. If greater than zero, a 1 x 1 00228 * pivot was used, otherwise a 2 x 2 pivot was used. 00229 * 00230 IF( IPIV( K ).GT.0 ) THEN 00231 * 00232 * 1 x 1 pivot block: 00233 * 00234 * Multiply by the diagonal element if forming L * D. 00235 * 00236 IF( NOUNIT ) 00237 $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) 00238 * 00239 * Multiply by P(K) * inv(L(K)) if K < N. 00240 * 00241 IF( K.NE.N ) THEN 00242 KP = IPIV( K ) 00243 * 00244 * Apply the transformation. 00245 * 00246 CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ), 00247 $ LDB, B( K+1, 1 ), LDB ) 00248 * 00249 * Interchange if a permutation was applied at the 00250 * K-th step of the factorization. 00251 * 00252 IF( KP.NE.K ) 00253 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 00254 END IF 00255 K = K - 1 00256 * 00257 ELSE 00258 * 00259 * 2 x 2 pivot block: 00260 * 00261 * Multiply by the diagonal block if forming L * D. 00262 * 00263 IF( NOUNIT ) THEN 00264 D11 = A( K-1, K-1 ) 00265 D22 = A( K, K ) 00266 D21 = A( K, K-1 ) 00267 D12 = D21 00268 DO 50 J = 1, NRHS 00269 T1 = B( K-1, J ) 00270 T2 = B( K, J ) 00271 B( K-1, J ) = D11*T1 + D12*T2 00272 B( K, J ) = D21*T1 + D22*T2 00273 50 CONTINUE 00274 END IF 00275 * 00276 * Multiply by P(K) * inv(L(K)) if K < N. 00277 * 00278 IF( K.NE.N ) THEN 00279 * 00280 * Apply the transformation. 00281 * 00282 CALL SGER( N-K, NRHS, ONE, A( K+1, K ), 1, B( K, 1 ), 00283 $ LDB, B( K+1, 1 ), LDB ) 00284 CALL SGER( N-K, NRHS, ONE, A( K+1, K-1 ), 1, 00285 $ B( K-1, 1 ), LDB, B( K+1, 1 ), LDB ) 00286 * 00287 * Interchange if a permutation was applied at the 00288 * K-th step of the factorization. 00289 * 00290 KP = ABS( IPIV( K ) ) 00291 IF( KP.NE.K ) 00292 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 00293 END IF 00294 K = K - 2 00295 END IF 00296 GO TO 40 00297 60 CONTINUE 00298 END IF 00299 *---------------------------------------- 00300 * 00301 * Compute B := A' * B (transpose) 00302 * 00303 *---------------------------------------- 00304 ELSE 00305 * 00306 * Form B := U'*B 00307 * where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) 00308 * and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) 00309 * 00310 IF( LSAME( UPLO, 'U' ) ) THEN 00311 * 00312 * Loop backward applying the transformations. 00313 * 00314 K = N 00315 70 CONTINUE 00316 IF( K.LT.1 ) 00317 $ GO TO 90 00318 * 00319 * 1 x 1 pivot block. 00320 * 00321 IF( IPIV( K ).GT.0 ) THEN 00322 IF( K.GT.1 ) THEN 00323 * 00324 * Interchange if P(K) .ne. I. 00325 * 00326 KP = IPIV( K ) 00327 IF( KP.NE.K ) 00328 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 00329 * 00330 * Apply the transformation 00331 * 00332 CALL SGEMV( 'Transpose', K-1, NRHS, ONE, B, LDB, 00333 $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) 00334 END IF 00335 IF( NOUNIT ) 00336 $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) 00337 K = K - 1 00338 * 00339 * 2 x 2 pivot block. 00340 * 00341 ELSE 00342 IF( K.GT.2 ) THEN 00343 * 00344 * Interchange if P(K) .ne. I. 00345 * 00346 KP = ABS( IPIV( K ) ) 00347 IF( KP.NE.K-1 ) 00348 $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), 00349 $ LDB ) 00350 * 00351 * Apply the transformations 00352 * 00353 CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, 00354 $ A( 1, K ), 1, ONE, B( K, 1 ), LDB ) 00355 CALL SGEMV( 'Transpose', K-2, NRHS, ONE, B, LDB, 00356 $ A( 1, K-1 ), 1, ONE, B( K-1, 1 ), LDB ) 00357 END IF 00358 * 00359 * Multiply by the diagonal block if non-unit. 00360 * 00361 IF( NOUNIT ) THEN 00362 D11 = A( K-1, K-1 ) 00363 D22 = A( K, K ) 00364 D12 = A( K-1, K ) 00365 D21 = D12 00366 DO 80 J = 1, NRHS 00367 T1 = B( K-1, J ) 00368 T2 = B( K, J ) 00369 B( K-1, J ) = D11*T1 + D12*T2 00370 B( K, J ) = D21*T1 + D22*T2 00371 80 CONTINUE 00372 END IF 00373 K = K - 2 00374 END IF 00375 GO TO 70 00376 90 CONTINUE 00377 * 00378 * Form B := L'*B 00379 * where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) 00380 * and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) 00381 * 00382 ELSE 00383 * 00384 * Loop forward applying the L-transformations. 00385 * 00386 K = 1 00387 100 CONTINUE 00388 IF( K.GT.N ) 00389 $ GO TO 120 00390 * 00391 * 1 x 1 pivot block 00392 * 00393 IF( IPIV( K ).GT.0 ) THEN 00394 IF( K.LT.N ) THEN 00395 * 00396 * Interchange if P(K) .ne. I. 00397 * 00398 KP = IPIV( K ) 00399 IF( KP.NE.K ) 00400 $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) 00401 * 00402 * Apply the transformation 00403 * 00404 CALL SGEMV( 'Transpose', N-K, NRHS, ONE, B( K+1, 1 ), 00405 $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB ) 00406 END IF 00407 IF( NOUNIT ) 00408 $ CALL SSCAL( NRHS, A( K, K ), B( K, 1 ), LDB ) 00409 K = K + 1 00410 * 00411 * 2 x 2 pivot block. 00412 * 00413 ELSE 00414 IF( K.LT.N-1 ) THEN 00415 * 00416 * Interchange if P(K) .ne. I. 00417 * 00418 KP = ABS( IPIV( K ) ) 00419 IF( KP.NE.K+1 ) 00420 $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), 00421 $ LDB ) 00422 * 00423 * Apply the transformation 00424 * 00425 CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE, 00426 $ B( K+2, 1 ), LDB, A( K+2, K+1 ), 1, ONE, 00427 $ B( K+1, 1 ), LDB ) 00428 CALL SGEMV( 'Transpose', N-K-1, NRHS, ONE, 00429 $ B( K+2, 1 ), LDB, A( K+2, K ), 1, ONE, 00430 $ B( K, 1 ), LDB ) 00431 END IF 00432 * 00433 * Multiply by the diagonal block if non-unit. 00434 * 00435 IF( NOUNIT ) THEN 00436 D11 = A( K, K ) 00437 D22 = A( K+1, K+1 ) 00438 D21 = A( K+1, K ) 00439 D12 = D21 00440 DO 110 J = 1, NRHS 00441 T1 = B( K, J ) 00442 T2 = B( K+1, J ) 00443 B( K, J ) = D11*T1 + D12*T2 00444 B( K+1, J ) = D21*T1 + D22*T2 00445 110 CONTINUE 00446 END IF 00447 K = K + 2 00448 END IF 00449 GO TO 100 00450 120 CONTINUE 00451 END IF 00452 * 00453 END IF 00454 RETURN 00455 * 00456 * End of SLAVSY 00457 * 00458 END
1.7.3 
