|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) 00002 * .. Scalar Arguments .. 00003 REAL ALPHA,BETA 00004 INTEGER INCX,INCY,KL,KU,LDA,M,N 00005 CHARACTER TRANS 00006 * .. 00007 * .. Array Arguments .. 00008 REAL A(LDA,*),X(*),Y(*) 00009 * .. 00010 * 00011 * Purpose 00012 * ======= 00013 * 00014 * SGBMV performs one of the matrix-vector operations 00015 * 00016 * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, 00017 * 00018 * where alpha and beta are scalars, x and y are vectors and A is an 00019 * m by n band matrix, with kl sub-diagonals and ku super-diagonals. 00020 * 00021 * Arguments 00022 * ========== 00023 * 00024 * TRANS - CHARACTER*1. 00025 * On entry, TRANS specifies the operation to be performed as 00026 * follows: 00027 * 00028 * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. 00029 * 00030 * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. 00031 * 00032 * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. 00033 * 00034 * Unchanged on exit. 00035 * 00036 * M - INTEGER. 00037 * On entry, M specifies the number of rows of the matrix A. 00038 * M must be at least zero. 00039 * Unchanged on exit. 00040 * 00041 * N - INTEGER. 00042 * On entry, N specifies the number of columns of the matrix A. 00043 * N must be at least zero. 00044 * Unchanged on exit. 00045 * 00046 * KL - INTEGER. 00047 * On entry, KL specifies the number of sub-diagonals of the 00048 * matrix A. KL must satisfy 0 .le. KL. 00049 * Unchanged on exit. 00050 * 00051 * KU - INTEGER. 00052 * On entry, KU specifies the number of super-diagonals of the 00053 * matrix A. KU must satisfy 0 .le. KU. 00054 * Unchanged on exit. 00055 * 00056 * ALPHA - REAL . 00057 * On entry, ALPHA specifies the scalar alpha. 00058 * Unchanged on exit. 00059 * 00060 * A - REAL array of DIMENSION ( LDA, n ). 00061 * Before entry, the leading ( kl + ku + 1 ) by n part of the 00062 * array A must contain the matrix of coefficients, supplied 00063 * column by column, with the leading diagonal of the matrix in 00064 * row ( ku + 1 ) of the array, the first super-diagonal 00065 * starting at position 2 in row ku, the first sub-diagonal 00066 * starting at position 1 in row ( ku + 2 ), and so on. 00067 * Elements in the array A that do not correspond to elements 00068 * in the band matrix (such as the top left ku by ku triangle) 00069 * are not referenced. 00070 * The following program segment will transfer a band matrix 00071 * from conventional full matrix storage to band storage: 00072 * 00073 * DO 20, J = 1, N 00074 * K = KU + 1 - J 00075 * DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) 00076 * A( K + I, J ) = matrix( I, J ) 00077 * 10 CONTINUE 00078 * 20 CONTINUE 00079 * 00080 * Unchanged on exit. 00081 * 00082 * LDA - INTEGER. 00083 * On entry, LDA specifies the first dimension of A as declared 00084 * in the calling (sub) program. LDA must be at least 00085 * ( kl + ku + 1 ). 00086 * Unchanged on exit. 00087 * 00088 * X - REAL array of DIMENSION at least 00089 * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' 00090 * and at least 00091 * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. 00092 * Before entry, the incremented array X must contain the 00093 * vector x. 00094 * Unchanged on exit. 00095 * 00096 * INCX - INTEGER. 00097 * On entry, INCX specifies the increment for the elements of 00098 * X. INCX must not be zero. 00099 * Unchanged on exit. 00100 * 00101 * BETA - REAL . 00102 * On entry, BETA specifies the scalar beta. When BETA is 00103 * supplied as zero then Y need not be set on input. 00104 * Unchanged on exit. 00105 * 00106 * Y - REAL array of DIMENSION at least 00107 * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' 00108 * and at least 00109 * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. 00110 * Before entry, the incremented array Y must contain the 00111 * vector y. On exit, Y is overwritten by the updated vector y. 00112 * 00113 * INCY - INTEGER. 00114 * On entry, INCY specifies the increment for the elements of 00115 * Y. INCY must not be zero. 00116 * Unchanged on exit. 00117 * 00118 * Further Details 00119 * =============== 00120 * 00121 * Level 2 Blas routine. 00122 * 00123 * -- Written on 22-October-1986. 00124 * Jack Dongarra, Argonne National Lab. 00125 * Jeremy Du Croz, Nag Central Office. 00126 * Sven Hammarling, Nag Central Office. 00127 * Richard Hanson, Sandia National Labs. 00128 * 00129 * ===================================================================== 00130 * 00131 * .. Parameters .. 00132 REAL ONE,ZERO 00133 PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) 00134 * .. 00135 * .. Local Scalars .. 00136 REAL TEMP 00137 INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY 00138 * .. 00139 * .. External Functions .. 00140 LOGICAL LSAME 00141 EXTERNAL LSAME 00142 * .. 00143 * .. External Subroutines .. 00144 EXTERNAL XERBLA 00145 * .. 00146 * .. Intrinsic Functions .. 00147 INTRINSIC MAX,MIN 00148 * .. 00149 * 00150 * Test the input parameters. 00151 * 00152 INFO = 0 00153 IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. 00154 + .NOT.LSAME(TRANS,'C')) THEN 00155 INFO = 1 00156 ELSE IF (M.LT.0) THEN 00157 INFO = 2 00158 ELSE IF (N.LT.0) THEN 00159 INFO = 3 00160 ELSE IF (KL.LT.0) THEN 00161 INFO = 4 00162 ELSE IF (KU.LT.0) THEN 00163 INFO = 5 00164 ELSE IF (LDA.LT. (KL+KU+1)) THEN 00165 INFO = 8 00166 ELSE IF (INCX.EQ.0) THEN 00167 INFO = 10 00168 ELSE IF (INCY.EQ.0) THEN 00169 INFO = 13 00170 END IF 00171 IF (INFO.NE.0) THEN 00172 CALL XERBLA('SGBMV ',INFO) 00173 RETURN 00174 END IF 00175 * 00176 * Quick return if possible. 00177 * 00178 IF ((M.EQ.0) .OR. (N.EQ.0) .OR. 00179 + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN 00180 * 00181 * Set LENX and LENY, the lengths of the vectors x and y, and set 00182 * up the start points in X and Y. 00183 * 00184 IF (LSAME(TRANS,'N')) THEN 00185 LENX = N 00186 LENY = M 00187 ELSE 00188 LENX = M 00189 LENY = N 00190 END IF 00191 IF (INCX.GT.0) THEN 00192 KX = 1 00193 ELSE 00194 KX = 1 - (LENX-1)*INCX 00195 END IF 00196 IF (INCY.GT.0) THEN 00197 KY = 1 00198 ELSE 00199 KY = 1 - (LENY-1)*INCY 00200 END IF 00201 * 00202 * Start the operations. In this version the elements of A are 00203 * accessed sequentially with one pass through the band part of A. 00204 * 00205 * First form y := beta*y. 00206 * 00207 IF (BETA.NE.ONE) THEN 00208 IF (INCY.EQ.1) THEN 00209 IF (BETA.EQ.ZERO) THEN 00210 DO 10 I = 1,LENY 00211 Y(I) = ZERO 00212 10 CONTINUE 00213 ELSE 00214 DO 20 I = 1,LENY 00215 Y(I) = BETA*Y(I) 00216 20 CONTINUE 00217 END IF 00218 ELSE 00219 IY = KY 00220 IF (BETA.EQ.ZERO) THEN 00221 DO 30 I = 1,LENY 00222 Y(IY) = ZERO 00223 IY = IY + INCY 00224 30 CONTINUE 00225 ELSE 00226 DO 40 I = 1,LENY 00227 Y(IY) = BETA*Y(IY) 00228 IY = IY + INCY 00229 40 CONTINUE 00230 END IF 00231 END IF 00232 END IF 00233 IF (ALPHA.EQ.ZERO) RETURN 00234 KUP1 = KU + 1 00235 IF (LSAME(TRANS,'N')) THEN 00236 * 00237 * Form y := alpha*A*x + y. 00238 * 00239 JX = KX 00240 IF (INCY.EQ.1) THEN 00241 DO 60 J = 1,N 00242 IF (X(JX).NE.ZERO) THEN 00243 TEMP = ALPHA*X(JX) 00244 K = KUP1 - J 00245 DO 50 I = MAX(1,J-KU),MIN(M,J+KL) 00246 Y(I) = Y(I) + TEMP*A(K+I,J) 00247 50 CONTINUE 00248 END IF 00249 JX = JX + INCX 00250 60 CONTINUE 00251 ELSE 00252 DO 80 J = 1,N 00253 IF (X(JX).NE.ZERO) THEN 00254 TEMP = ALPHA*X(JX) 00255 IY = KY 00256 K = KUP1 - J 00257 DO 70 I = MAX(1,J-KU),MIN(M,J+KL) 00258 Y(IY) = Y(IY) + TEMP*A(K+I,J) 00259 IY = IY + INCY 00260 70 CONTINUE 00261 END IF 00262 JX = JX + INCX 00263 IF (J.GT.KU) KY = KY + INCY 00264 80 CONTINUE 00265 END IF 00266 ELSE 00267 * 00268 * Form y := alpha*A'*x + y. 00269 * 00270 JY = KY 00271 IF (INCX.EQ.1) THEN 00272 DO 100 J = 1,N 00273 TEMP = ZERO 00274 K = KUP1 - J 00275 DO 90 I = MAX(1,J-KU),MIN(M,J+KL) 00276 TEMP = TEMP + A(K+I,J)*X(I) 00277 90 CONTINUE 00278 Y(JY) = Y(JY) + ALPHA*TEMP 00279 JY = JY + INCY 00280 100 CONTINUE 00281 ELSE 00282 DO 120 J = 1,N 00283 TEMP = ZERO 00284 IX = KX 00285 K = KUP1 - J 00286 DO 110 I = MAX(1,J-KU),MIN(M,J+KL) 00287 TEMP = TEMP + A(K+I,J)*X(IX) 00288 IX = IX + INCX 00289 110 CONTINUE 00290 Y(JY) = Y(JY) + ALPHA*TEMP 00291 JY = JY + INCY 00292 IF (J.GT.KU) KX = KX + INCX 00293 120 CONTINUE 00294 END IF 00295 END IF 00296 * 00297 RETURN 00298 * 00299 * End of SGBMV . 00300 * 00301 END
1.7.3 
