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