|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC) 00002 * .. Scalar Arguments .. 00003 REAL ALPHA,BETA 00004 INTEGER LDA,LDB,LDC,M,N 00005 CHARACTER SIDE,UPLO 00006 * .. 00007 * .. Array Arguments .. 00008 REAL A(LDA,*),B(LDB,*),C(LDC,*) 00009 * .. 00010 * 00011 * Purpose 00012 * ======= 00013 * 00014 * SSYMM performs one of the matrix-matrix operations 00015 * 00016 * C := alpha*A*B + beta*C, 00017 * 00018 * or 00019 * 00020 * C := alpha*B*A + beta*C, 00021 * 00022 * where alpha and beta are scalars, A is a symmetric matrix and B and 00023 * C are m by n matrices. 00024 * 00025 * Arguments 00026 * ========== 00027 * 00028 * SIDE - CHARACTER*1. 00029 * On entry, SIDE specifies whether the symmetric matrix A 00030 * appears on the left or right in the operation as follows: 00031 * 00032 * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, 00033 * 00034 * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, 00035 * 00036 * Unchanged on exit. 00037 * 00038 * UPLO - CHARACTER*1. 00039 * On entry, UPLO specifies whether the upper or lower 00040 * triangular part of the symmetric matrix A is to be 00041 * referenced as follows: 00042 * 00043 * UPLO = 'U' or 'u' Only the upper triangular part of the 00044 * symmetric matrix is to be referenced. 00045 * 00046 * UPLO = 'L' or 'l' Only the lower triangular part of the 00047 * symmetric matrix is to be referenced. 00048 * 00049 * Unchanged on exit. 00050 * 00051 * M - INTEGER. 00052 * On entry, M specifies the number of rows of the matrix C. 00053 * M must be at least zero. 00054 * Unchanged on exit. 00055 * 00056 * N - INTEGER. 00057 * On entry, N specifies the number of columns of the matrix C. 00058 * N must be at least zero. 00059 * Unchanged on exit. 00060 * 00061 * ALPHA - REAL . 00062 * On entry, ALPHA specifies the scalar alpha. 00063 * Unchanged on exit. 00064 * 00065 * A - REAL array of DIMENSION ( LDA, ka ), where ka is 00066 * m when SIDE = 'L' or 'l' and is n otherwise. 00067 * Before entry with SIDE = 'L' or 'l', the m by m part of 00068 * the array A must contain the symmetric matrix, such that 00069 * when UPLO = 'U' or 'u', the leading m by m upper triangular 00070 * part of the array A must contain the upper triangular part 00071 * of the symmetric matrix and the strictly lower triangular 00072 * part of A is not referenced, and when UPLO = 'L' or 'l', 00073 * the leading m by m lower triangular part of the array A 00074 * must contain the lower triangular part of the symmetric 00075 * matrix and the strictly upper triangular part of A is not 00076 * referenced. 00077 * Before entry with SIDE = 'R' or 'r', the n by n part of 00078 * the array A must contain the symmetric matrix, such that 00079 * when UPLO = 'U' or 'u', the leading n by n upper triangular 00080 * part of the array A must contain the upper triangular part 00081 * of the symmetric matrix and the strictly lower triangular 00082 * part of A is not referenced, and when UPLO = 'L' or 'l', 00083 * the leading n by n lower triangular part of the array A 00084 * must contain the lower triangular part of the symmetric 00085 * matrix and the strictly upper triangular part of A is not 00086 * referenced. 00087 * Unchanged on exit. 00088 * 00089 * LDA - INTEGER. 00090 * On entry, LDA specifies the first dimension of A as declared 00091 * in the calling (sub) program. When SIDE = 'L' or 'l' then 00092 * LDA must be at least max( 1, m ), otherwise LDA must be at 00093 * least max( 1, n ). 00094 * Unchanged on exit. 00095 * 00096 * B - REAL array of DIMENSION ( LDB, n ). 00097 * Before entry, the leading m by n part of the array B must 00098 * contain the matrix B. 00099 * Unchanged on exit. 00100 * 00101 * LDB - INTEGER. 00102 * On entry, LDB specifies the first dimension of B as declared 00103 * in the calling (sub) program. LDB must be at least 00104 * max( 1, m ). 00105 * Unchanged on exit. 00106 * 00107 * BETA - REAL . 00108 * On entry, BETA specifies the scalar beta. When BETA is 00109 * supplied as zero then C need not be set on input. 00110 * Unchanged on exit. 00111 * 00112 * C - REAL array of DIMENSION ( LDC, n ). 00113 * Before entry, the leading m by n part of the array C must 00114 * contain the matrix C, except when beta is zero, in which 00115 * case C need not be set on entry. 00116 * On exit, the array C is overwritten by the m by n updated 00117 * matrix. 00118 * 00119 * LDC - INTEGER. 00120 * On entry, LDC specifies the first dimension of C as declared 00121 * in the calling (sub) program. LDC must be at least 00122 * max( 1, m ). 00123 * Unchanged on exit. 00124 * 00125 * Further Details 00126 * =============== 00127 * 00128 * Level 3 Blas routine. 00129 * 00130 * -- Written on 8-February-1989. 00131 * Jack Dongarra, Argonne National Laboratory. 00132 * Iain Duff, AERE Harwell. 00133 * Jeremy Du Croz, Numerical Algorithms Group Ltd. 00134 * Sven Hammarling, Numerical Algorithms Group Ltd. 00135 * 00136 * ===================================================================== 00137 * 00138 * .. External Functions .. 00139 LOGICAL LSAME 00140 EXTERNAL LSAME 00141 * .. 00142 * .. External Subroutines .. 00143 EXTERNAL XERBLA 00144 * .. 00145 * .. Intrinsic Functions .. 00146 INTRINSIC MAX 00147 * .. 00148 * .. Local Scalars .. 00149 REAL TEMP1,TEMP2 00150 INTEGER I,INFO,J,K,NROWA 00151 LOGICAL UPPER 00152 * .. 00153 * .. Parameters .. 00154 REAL ONE,ZERO 00155 PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) 00156 * .. 00157 * 00158 * Set NROWA as the number of rows of A. 00159 * 00160 IF (LSAME(SIDE,'L')) THEN 00161 NROWA = M 00162 ELSE 00163 NROWA = N 00164 END IF 00165 UPPER = LSAME(UPLO,'U') 00166 * 00167 * Test the input parameters. 00168 * 00169 INFO = 0 00170 IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN 00171 INFO = 1 00172 ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN 00173 INFO = 2 00174 ELSE IF (M.LT.0) THEN 00175 INFO = 3 00176 ELSE IF (N.LT.0) THEN 00177 INFO = 4 00178 ELSE IF (LDA.LT.MAX(1,NROWA)) THEN 00179 INFO = 7 00180 ELSE IF (LDB.LT.MAX(1,M)) THEN 00181 INFO = 9 00182 ELSE IF (LDC.LT.MAX(1,M)) THEN 00183 INFO = 12 00184 END IF 00185 IF (INFO.NE.0) THEN 00186 CALL XERBLA('SSYMM ',INFO) 00187 RETURN 00188 END IF 00189 * 00190 * Quick return if possible. 00191 * 00192 IF ((M.EQ.0) .OR. (N.EQ.0) .OR. 00193 + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN 00194 * 00195 * And when alpha.eq.zero. 00196 * 00197 IF (ALPHA.EQ.ZERO) THEN 00198 IF (BETA.EQ.ZERO) THEN 00199 DO 20 J = 1,N 00200 DO 10 I = 1,M 00201 C(I,J) = ZERO 00202 10 CONTINUE 00203 20 CONTINUE 00204 ELSE 00205 DO 40 J = 1,N 00206 DO 30 I = 1,M 00207 C(I,J) = BETA*C(I,J) 00208 30 CONTINUE 00209 40 CONTINUE 00210 END IF 00211 RETURN 00212 END IF 00213 * 00214 * Start the operations. 00215 * 00216 IF (LSAME(SIDE,'L')) THEN 00217 * 00218 * Form C := alpha*A*B + beta*C. 00219 * 00220 IF (UPPER) THEN 00221 DO 70 J = 1,N 00222 DO 60 I = 1,M 00223 TEMP1 = ALPHA*B(I,J) 00224 TEMP2 = ZERO 00225 DO 50 K = 1,I - 1 00226 C(K,J) = C(K,J) + TEMP1*A(K,I) 00227 TEMP2 = TEMP2 + B(K,J)*A(K,I) 00228 50 CONTINUE 00229 IF (BETA.EQ.ZERO) THEN 00230 C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 00231 ELSE 00232 C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + 00233 + ALPHA*TEMP2 00234 END IF 00235 60 CONTINUE 00236 70 CONTINUE 00237 ELSE 00238 DO 100 J = 1,N 00239 DO 90 I = M,1,-1 00240 TEMP1 = ALPHA*B(I,J) 00241 TEMP2 = ZERO 00242 DO 80 K = I + 1,M 00243 C(K,J) = C(K,J) + TEMP1*A(K,I) 00244 TEMP2 = TEMP2 + B(K,J)*A(K,I) 00245 80 CONTINUE 00246 IF (BETA.EQ.ZERO) THEN 00247 C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2 00248 ELSE 00249 C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) + 00250 + ALPHA*TEMP2 00251 END IF 00252 90 CONTINUE 00253 100 CONTINUE 00254 END IF 00255 ELSE 00256 * 00257 * Form C := alpha*B*A + beta*C. 00258 * 00259 DO 170 J = 1,N 00260 TEMP1 = ALPHA*A(J,J) 00261 IF (BETA.EQ.ZERO) THEN 00262 DO 110 I = 1,M 00263 C(I,J) = TEMP1*B(I,J) 00264 110 CONTINUE 00265 ELSE 00266 DO 120 I = 1,M 00267 C(I,J) = BETA*C(I,J) + TEMP1*B(I,J) 00268 120 CONTINUE 00269 END IF 00270 DO 140 K = 1,J - 1 00271 IF (UPPER) THEN 00272 TEMP1 = ALPHA*A(K,J) 00273 ELSE 00274 TEMP1 = ALPHA*A(J,K) 00275 END IF 00276 DO 130 I = 1,M 00277 C(I,J) = C(I,J) + TEMP1*B(I,K) 00278 130 CONTINUE 00279 140 CONTINUE 00280 DO 160 K = J + 1,N 00281 IF (UPPER) THEN 00282 TEMP1 = ALPHA*A(J,K) 00283 ELSE 00284 TEMP1 = ALPHA*A(K,J) 00285 END IF 00286 DO 150 I = 1,M 00287 C(I,J) = C(I,J) + TEMP1*B(I,K) 00288 150 CONTINUE 00289 160 CONTINUE 00290 170 CONTINUE 00291 END IF 00292 * 00293 RETURN 00294 * 00295 * End of SSYMM . 00296 * 00297 END
1.7.3 
