![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CSYR2K 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) 00012 * 00013 * .. Scalar Arguments .. 00014 * COMPLEX ALPHA,BETA 00015 * INTEGER K,LDA,LDB,LDC,N 00016 * CHARACTER TRANS,UPLO 00017 * .. 00018 * .. Array Arguments .. 00019 * COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) 00020 * .. 00021 * 00022 * 00023 *> \par Purpose: 00024 * ============= 00025 *> 00026 *> \verbatim 00027 *> 00028 *> CSYR2K performs one of the symmetric rank 2k operations 00029 *> 00030 *> C := alpha*A*B**T + alpha*B*A**T + beta*C, 00031 *> 00032 *> or 00033 *> 00034 *> C := alpha*A**T*B + alpha*B**T*A + beta*C, 00035 *> 00036 *> where alpha and beta are scalars, C is an n by n symmetric matrix 00037 *> and A and B are n by k matrices in the first case and k by n 00038 *> matrices in the second case. 00039 *> \endverbatim 00040 * 00041 * Arguments: 00042 * ========== 00043 * 00044 *> \param[in] UPLO 00045 *> \verbatim 00046 *> UPLO is CHARACTER*1 00047 *> On entry, UPLO specifies whether the upper or lower 00048 *> triangular part of the array C is to be referenced as 00049 *> follows: 00050 *> 00051 *> UPLO = 'U' or 'u' Only the upper triangular part of C 00052 *> is to be referenced. 00053 *> 00054 *> UPLO = 'L' or 'l' Only the lower triangular part of C 00055 *> is to be referenced. 00056 *> \endverbatim 00057 *> 00058 *> \param[in] TRANS 00059 *> \verbatim 00060 *> TRANS is CHARACTER*1 00061 *> On entry, TRANS specifies the operation to be performed as 00062 *> follows: 00063 *> 00064 *> TRANS = 'N' or 'n' C := alpha*A*B**T + alpha*B*A**T + 00065 *> beta*C. 00066 *> 00067 *> TRANS = 'T' or 't' C := alpha*A**T*B + alpha*B**T*A + 00068 *> beta*C. 00069 *> \endverbatim 00070 *> 00071 *> \param[in] N 00072 *> \verbatim 00073 *> N is INTEGER 00074 *> On entry, N specifies the order of the matrix C. N must be 00075 *> at least zero. 00076 *> \endverbatim 00077 *> 00078 *> \param[in] K 00079 *> \verbatim 00080 *> K is INTEGER 00081 *> On entry with TRANS = 'N' or 'n', K specifies the number 00082 *> of columns of the matrices A and B, and on entry with 00083 *> TRANS = 'T' or 't', K specifies the number of rows of the 00084 *> matrices A and B. K must be at least zero. 00085 *> \endverbatim 00086 *> 00087 *> \param[in] ALPHA 00088 *> \verbatim 00089 *> ALPHA is COMPLEX 00090 *> On entry, ALPHA specifies the scalar alpha. 00091 *> \endverbatim 00092 *> 00093 *> \param[in] A 00094 *> \verbatim 00095 *> A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is 00096 *> k when TRANS = 'N' or 'n', and is n otherwise. 00097 *> Before entry with TRANS = 'N' or 'n', the leading n by k 00098 *> part of the array A must contain the matrix A, otherwise 00099 *> the leading k by n part of the array A must contain the 00100 *> matrix A. 00101 *> \endverbatim 00102 *> 00103 *> \param[in] LDA 00104 *> \verbatim 00105 *> LDA is INTEGER 00106 *> On entry, LDA specifies the first dimension of A as declared 00107 *> in the calling (sub) program. When TRANS = 'N' or 'n' 00108 *> then LDA must be at least max( 1, n ), otherwise LDA must 00109 *> be at least max( 1, k ). 00110 *> \endverbatim 00111 *> 00112 *> \param[in] B 00113 *> \verbatim 00114 *> B is COMPLEX array of DIMENSION ( LDB, kb ), where kb is 00115 *> k when TRANS = 'N' or 'n', and is n otherwise. 00116 *> Before entry with TRANS = 'N' or 'n', the leading n by k 00117 *> part of the array B must contain the matrix B, otherwise 00118 *> the leading k by n part of the array B must contain the 00119 *> matrix B. 00120 *> \endverbatim 00121 *> 00122 *> \param[in] LDB 00123 *> \verbatim 00124 *> LDB is INTEGER 00125 *> On entry, LDB specifies the first dimension of B as declared 00126 *> in the calling (sub) program. When TRANS = 'N' or 'n' 00127 *> then LDB must be at least max( 1, n ), otherwise LDB must 00128 *> be at least max( 1, k ). 00129 *> \endverbatim 00130 *> 00131 *> \param[in] BETA 00132 *> \verbatim 00133 *> BETA is COMPLEX 00134 *> On entry, BETA specifies the scalar beta. 00135 *> \endverbatim 00136 *> 00137 *> \param[in,out] C 00138 *> \verbatim 00139 *> C is COMPLEX array of DIMENSION ( LDC, n ). 00140 *> Before entry with UPLO = 'U' or 'u', the leading n by n 00141 *> upper triangular part of the array C must contain the upper 00142 *> triangular part of the symmetric matrix and the strictly 00143 *> lower triangular part of C is not referenced. On exit, the 00144 *> upper triangular part of the array C is overwritten by the 00145 *> upper triangular part of the updated matrix. 00146 *> Before entry with UPLO = 'L' or 'l', the leading n by n 00147 *> lower triangular part of the array C must contain the lower 00148 *> triangular part of the symmetric matrix and the strictly 00149 *> upper triangular part of C is not referenced. On exit, the 00150 *> lower triangular part of the array C is overwritten by the 00151 *> lower triangular part of the updated matrix. 00152 *> \endverbatim 00153 *> 00154 *> \param[in] LDC 00155 *> \verbatim 00156 *> LDC is INTEGER 00157 *> On entry, LDC specifies the first dimension of C as declared 00158 *> in the calling (sub) program. LDC must be at least 00159 *> max( 1, n ). 00160 *> \endverbatim 00161 * 00162 * Authors: 00163 * ======== 00164 * 00165 *> \author Univ. of Tennessee 00166 *> \author Univ. of California Berkeley 00167 *> \author Univ. of Colorado Denver 00168 *> \author NAG Ltd. 00169 * 00170 *> \date November 2011 00171 * 00172 *> \ingroup complex_blas_level3 00173 * 00174 *> \par Further Details: 00175 * ===================== 00176 *> 00177 *> \verbatim 00178 *> 00179 *> Level 3 Blas routine. 00180 *> 00181 *> -- Written on 8-February-1989. 00182 *> Jack Dongarra, Argonne National Laboratory. 00183 *> Iain Duff, AERE Harwell. 00184 *> Jeremy Du Croz, Numerical Algorithms Group Ltd. 00185 *> Sven Hammarling, Numerical Algorithms Group Ltd. 00186 *> \endverbatim 00187 *> 00188 * ===================================================================== 00189 SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) 00190 * 00191 * -- Reference BLAS level3 routine (version 3.4.0) -- 00192 * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 00193 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00194 * November 2011 00195 * 00196 * .. Scalar Arguments .. 00197 COMPLEX ALPHA,BETA 00198 INTEGER K,LDA,LDB,LDC,N 00199 CHARACTER TRANS,UPLO 00200 * .. 00201 * .. Array Arguments .. 00202 COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) 00203 * .. 00204 * 00205 * ===================================================================== 00206 * 00207 * .. External Functions .. 00208 LOGICAL LSAME 00209 EXTERNAL LSAME 00210 * .. 00211 * .. External Subroutines .. 00212 EXTERNAL XERBLA 00213 * .. 00214 * .. Intrinsic Functions .. 00215 INTRINSIC MAX 00216 * .. 00217 * .. Local Scalars .. 00218 COMPLEX TEMP1,TEMP2 00219 INTEGER I,INFO,J,L,NROWA 00220 LOGICAL UPPER 00221 * .. 00222 * .. Parameters .. 00223 COMPLEX ONE 00224 PARAMETER (ONE= (1.0E+0,0.0E+0)) 00225 COMPLEX ZERO 00226 PARAMETER (ZERO= (0.0E+0,0.0E+0)) 00227 * .. 00228 * 00229 * Test the input parameters. 00230 * 00231 IF (LSAME(TRANS,'N')) THEN 00232 NROWA = N 00233 ELSE 00234 NROWA = K 00235 END IF 00236 UPPER = LSAME(UPLO,'U') 00237 * 00238 INFO = 0 00239 IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN 00240 INFO = 1 00241 ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND. 00242 + (.NOT.LSAME(TRANS,'T'))) THEN 00243 INFO = 2 00244 ELSE IF (N.LT.0) THEN 00245 INFO = 3 00246 ELSE IF (K.LT.0) THEN 00247 INFO = 4 00248 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN 00249 INFO = 7 00250 ELSE IF (LDB.LT.MAX(1,NROWA)) THEN 00251 INFO = 9 00252 ELSE IF (LDC.LT.MAX(1,N)) THEN 00253 INFO = 12 00254 END IF 00255 IF (INFO.NE.0) THEN 00256 CALL XERBLA('CSYR2K',INFO) 00257 RETURN 00258 END IF 00259 * 00260 * Quick return if possible. 00261 * 00262 IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR. 00263 + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN 00264 * 00265 * And when alpha.eq.zero. 00266 * 00267 IF (ALPHA.EQ.ZERO) THEN 00268 IF (UPPER) THEN 00269 IF (BETA.EQ.ZERO) THEN 00270 DO 20 J = 1,N 00271 DO 10 I = 1,J 00272 C(I,J) = ZERO 00273 10 CONTINUE 00274 20 CONTINUE 00275 ELSE 00276 DO 40 J = 1,N 00277 DO 30 I = 1,J 00278 C(I,J) = BETA*C(I,J) 00279 30 CONTINUE 00280 40 CONTINUE 00281 END IF 00282 ELSE 00283 IF (BETA.EQ.ZERO) THEN 00284 DO 60 J = 1,N 00285 DO 50 I = J,N 00286 C(I,J) = ZERO 00287 50 CONTINUE 00288 60 CONTINUE 00289 ELSE 00290 DO 80 J = 1,N 00291 DO 70 I = J,N 00292 C(I,J) = BETA*C(I,J) 00293 70 CONTINUE 00294 80 CONTINUE 00295 END IF 00296 END IF 00297 RETURN 00298 END IF 00299 * 00300 * Start the operations. 00301 * 00302 IF (LSAME(TRANS,'N')) THEN 00303 * 00304 * Form C := alpha*A*B**T + alpha*B*A**T + C. 00305 * 00306 IF (UPPER) THEN 00307 DO 130 J = 1,N 00308 IF (BETA.EQ.ZERO) THEN 00309 DO 90 I = 1,J 00310 C(I,J) = ZERO 00311 90 CONTINUE 00312 ELSE IF (BETA.NE.ONE) THEN 00313 DO 100 I = 1,J 00314 C(I,J) = BETA*C(I,J) 00315 100 CONTINUE 00316 END IF 00317 DO 120 L = 1,K 00318 IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN 00319 TEMP1 = ALPHA*B(J,L) 00320 TEMP2 = ALPHA*A(J,L) 00321 DO 110 I = 1,J 00322 C(I,J) = C(I,J) + A(I,L)*TEMP1 + 00323 + B(I,L)*TEMP2 00324 110 CONTINUE 00325 END IF 00326 120 CONTINUE 00327 130 CONTINUE 00328 ELSE 00329 DO 180 J = 1,N 00330 IF (BETA.EQ.ZERO) THEN 00331 DO 140 I = J,N 00332 C(I,J) = ZERO 00333 140 CONTINUE 00334 ELSE IF (BETA.NE.ONE) THEN 00335 DO 150 I = J,N 00336 C(I,J) = BETA*C(I,J) 00337 150 CONTINUE 00338 END IF 00339 DO 170 L = 1,K 00340 IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN 00341 TEMP1 = ALPHA*B(J,L) 00342 TEMP2 = ALPHA*A(J,L) 00343 DO 160 I = J,N 00344 C(I,J) = C(I,J) + A(I,L)*TEMP1 + 00345 + B(I,L)*TEMP2 00346 160 CONTINUE 00347 END IF 00348 170 CONTINUE 00349 180 CONTINUE 00350 END IF 00351 ELSE 00352 * 00353 * Form C := alpha*A**T*B + alpha*B**T*A + C. 00354 * 00355 IF (UPPER) THEN 00356 DO 210 J = 1,N 00357 DO 200 I = 1,J 00358 TEMP1 = ZERO 00359 TEMP2 = ZERO 00360 DO 190 L = 1,K 00361 TEMP1 = TEMP1 + A(L,I)*B(L,J) 00362 TEMP2 = TEMP2 + B(L,I)*A(L,J) 00363 190 CONTINUE 00364 IF (BETA.EQ.ZERO) THEN 00365 C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 00366 ELSE 00367 C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + 00368 + ALPHA*TEMP2 00369 END IF 00370 200 CONTINUE 00371 210 CONTINUE 00372 ELSE 00373 DO 240 J = 1,N 00374 DO 230 I = J,N 00375 TEMP1 = ZERO 00376 TEMP2 = ZERO 00377 DO 220 L = 1,K 00378 TEMP1 = TEMP1 + A(L,I)*B(L,J) 00379 TEMP2 = TEMP2 + B(L,I)*A(L,J) 00380 220 CONTINUE 00381 IF (BETA.EQ.ZERO) THEN 00382 C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2 00383 ELSE 00384 C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 + 00385 + ALPHA*TEMP2 00386 END IF 00387 230 CONTINUE 00388 240 CONTINUE 00389 END IF 00390 END IF 00391 * 00392 RETURN 00393 * 00394 * End of CSYR2K. 00395 * 00396 END