1 SUBROUTINE STPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) 2* .. Scalar Arguments .. 3 INTEGER INCX, N 4 CHARACTER*1 DIAG, TRANS, UPLO 5* .. Array Arguments .. 6 REAL AP( * ), X( * ) 7* .. 8* 9* Purpose 10* ======= 11* 12* STPMV performs one of the matrix-vector operations 13* 14* x := A*x, or x := A'*x, 15* 16* where x is an n element vector and A is an n by n unit, or non-unit, 17* upper or lower triangular matrix, supplied in packed form. 18* 19* Parameters 20* ========== 21* 22* UPLO - CHARACTER*1. 23* On entry, UPLO specifies whether the matrix is an upper or 24* lower triangular matrix as follows: 25* 26* UPLO = 'U' or 'u' A is an upper triangular matrix. 27* 28* UPLO = 'L' or 'l' A is a lower triangular matrix. 29* 30* Unchanged on exit. 31* 32* TRANS - CHARACTER*1. 33* On entry, TRANS specifies the operation to be performed as 34* follows: 35* 36* TRANS = 'N' or 'n' x := A*x. 37* 38* TRANS = 'T' or 't' x := A'*x. 39* 40* TRANS = 'C' or 'c' x := A'*x. 41* 42* Unchanged on exit. 43* 44* DIAG - CHARACTER*1. 45* On entry, DIAG specifies whether or not A is unit 46* triangular as follows: 47* 48* DIAG = 'U' or 'u' A is assumed to be unit triangular. 49* 50* DIAG = 'N' or 'n' A is not assumed to be unit 51* triangular. 52* 53* Unchanged on exit. 54* 55* N - INTEGER. 56* On entry, N specifies the order of the matrix A. 57* N must be at least zero. 58* Unchanged on exit. 59* 60* AP - REAL array of DIMENSION at least 61* ( ( n*( n + 1 ) )/2 ). 62* Before entry with UPLO = 'U' or 'u', the array AP must 63* contain the upper triangular matrix packed sequentially, 64* column by column, so that AP( 1 ) contains a( 1, 1 ), 65* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) 66* respectively, and so on. 67* Before entry with UPLO = 'L' or 'l', the array AP must 68* contain the lower triangular matrix packed sequentially, 69* column by column, so that AP( 1 ) contains a( 1, 1 ), 70* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) 71* respectively, and so on. 72* Note that when DIAG = 'U' or 'u', the diagonal elements of 73* A are not referenced, but are assumed to be unity. 74* Unchanged on exit. 75* 76* X - REAL array of dimension at least 77* ( 1 + ( n - 1 )*abs( INCX ) ). 78* Before entry, the incremented array X must contain the n 79* element vector x. On exit, X is overwritten with the 80* tranformed vector x. 81* 82* INCX - INTEGER. 83* On entry, INCX specifies the increment for the elements of 84* X. INCX must not be zero. 85* Unchanged on exit. 86* 87* 88* Level 2 Blas routine. 89* 90* -- Written on 22-October-1986. 91* Jack Dongarra, Argonne National Lab. 92* Jeremy Du Croz, Nag Central Office. 93* Sven Hammarling, Nag Central Office. 94* Richard Hanson, Sandia National Labs. 95* 96* 97* .. Parameters .. 98 REAL ZERO 99 PARAMETER ( ZERO = 0.0E+0 ) 100* .. Local Scalars .. 101 REAL TEMP 102 INTEGER I, INFO, IX, J, JX, K, KK, KX 103 LOGICAL NOUNIT 104* .. External Functions .. 105 LOGICAL LSAME 106 EXTERNAL LSAME 107* .. External Subroutines .. 108 EXTERNAL XERBLA 109* .. 110* .. Executable Statements .. 111* 112* Test the input parameters. 113* 114 INFO = 0 115 IF ( .NOT.LSAME( UPLO , 'U' ).AND. 116 $ .NOT.LSAME( UPLO , 'L' ) )THEN 117 INFO = 1 118 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. 119 $ .NOT.LSAME( TRANS, 'T' ).AND. 120 $ .NOT.LSAME( TRANS, 'C' ) )THEN 121 INFO = 2 122 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. 123 $ .NOT.LSAME( DIAG , 'N' ) )THEN 124 INFO = 3 125 ELSE IF( N.LT.0 )THEN 126 INFO = 4 127 ELSE IF( INCX.EQ.0 )THEN 128 INFO = 7 129 END IF 130 IF( INFO.NE.0 )THEN 131 CALL XERBLA( 'STPMV ', INFO ) 132 RETURN 133 END IF 134* 135* Quick return if possible. 136* 137 IF( N.EQ.0 ) 138 $ RETURN 139* 140 NOUNIT = LSAME( DIAG, 'N' ) 141* 142* Set up the start point in X if the increment is not unity. This 143* will be ( N - 1 )*INCX too small for descending loops. 144* 145 IF( INCX.LE.0 )THEN 146 KX = 1 - ( N - 1 )*INCX 147 ELSE IF( INCX.NE.1 )THEN 148 KX = 1 149 END IF 150* 151* Start the operations. In this version the elements of AP are 152* accessed sequentially with one pass through AP. 153* 154 IF( LSAME( TRANS, 'N' ) )THEN 155* 156* Form x:= A*x. 157* 158 IF( LSAME( UPLO, 'U' ) )THEN 159 KK =1 160 IF( INCX.EQ.1 )THEN 161 DO 20, J = 1, N 162 IF( X( J ).NE.ZERO )THEN 163 TEMP = X( J ) 164 K = KK 165 DO 10, I = 1, J - 1 166 X( I ) = X( I ) + TEMP*AP( K ) 167 K = K + 1 168 10 CONTINUE 169 IF( NOUNIT ) 170 $ X( J ) = X( J )*AP( KK + J - 1 ) 171 END IF 172 KK = KK + J 173 20 CONTINUE 174 ELSE 175 JX = KX 176 DO 40, J = 1, N 177 IF( X( JX ).NE.ZERO )THEN 178 TEMP = X( JX ) 179 IX = KX 180 DO 30, K = KK, KK + J - 2 181 X( IX ) = X( IX ) + TEMP*AP( K ) 182 IX = IX + INCX 183 30 CONTINUE 184 IF( NOUNIT ) 185 $ X( JX ) = X( JX )*AP( KK + J - 1 ) 186 END IF 187 JX = JX + INCX 188 KK = KK + J 189 40 CONTINUE 190 END IF 191 ELSE 192 KK = ( N*( N + 1 ) )/2 193 IF( INCX.EQ.1 )THEN 194 DO 60, J = N, 1, -1 195 IF( X( J ).NE.ZERO )THEN 196 TEMP = X( J ) 197 K = KK 198 DO 50, I = N, J + 1, -1 199 X( I ) = X( I ) + TEMP*AP( K ) 200 K = K - 1 201 50 CONTINUE 202 IF( NOUNIT ) 203 $ X( J ) = X( J )*AP( KK - N + J ) 204 END IF 205 KK = KK - ( N - J + 1 ) 206 60 CONTINUE 207 ELSE 208 KX = KX + ( N - 1 )*INCX 209 JX = KX 210 DO 80, J = N, 1, -1 211 IF( X( JX ).NE.ZERO )THEN 212 TEMP = X( JX ) 213 IX = KX 214 DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 215 X( IX ) = X( IX ) + TEMP*AP( K ) 216 IX = IX - INCX 217 70 CONTINUE 218 IF( NOUNIT ) 219 $ X( JX ) = X( JX )*AP( KK - N + J ) 220 END IF 221 JX = JX - INCX 222 KK = KK - ( N - J + 1 ) 223 80 CONTINUE 224 END IF 225 END IF 226 ELSE 227* 228* Form x := A'*x. 229* 230 IF( LSAME( UPLO, 'U' ) )THEN 231 KK = ( N*( N + 1 ) )/2 232 IF( INCX.EQ.1 )THEN 233 DO 100, J = N, 1, -1 234 TEMP = X( J ) 235 IF( NOUNIT ) 236 $ TEMP = TEMP*AP( KK ) 237 K = KK - 1 238 DO 90, I = J - 1, 1, -1 239 TEMP = TEMP + AP( K )*X( I ) 240 K = K - 1 241 90 CONTINUE 242 X( J ) = TEMP 243 KK = KK - J 244 100 CONTINUE 245 ELSE 246 JX = KX + ( N - 1 )*INCX 247 DO 120, J = N, 1, -1 248 TEMP = X( JX ) 249 IX = JX 250 IF( NOUNIT ) 251 $ TEMP = TEMP*AP( KK ) 252 DO 110, K = KK - 1, KK - J + 1, -1 253 IX = IX - INCX 254 TEMP = TEMP + AP( K )*X( IX ) 255 110 CONTINUE 256 X( JX ) = TEMP 257 JX = JX - INCX 258 KK = KK - J 259 120 CONTINUE 260 END IF 261 ELSE 262 KK = 1 263 IF( INCX.EQ.1 )THEN 264 DO 140, J = 1, N 265 TEMP = X( J ) 266 IF( NOUNIT ) 267 $ TEMP = TEMP*AP( KK ) 268 K = KK + 1 269 DO 130, I = J + 1, N 270 TEMP = TEMP + AP( K )*X( I ) 271 K = K + 1 272 130 CONTINUE 273 X( J ) = TEMP 274 KK = KK + ( N - J + 1 ) 275 140 CONTINUE 276 ELSE 277 JX = KX 278 DO 160, J = 1, N 279 TEMP = X( JX ) 280 IX = JX 281 IF( NOUNIT ) 282 $ TEMP = TEMP*AP( KK ) 283 DO 150, K = KK + 1, KK + N - J 284 IX = IX + INCX 285 TEMP = TEMP + AP( K )*X( IX ) 286 150 CONTINUE 287 X( JX ) = TEMP 288 JX = JX + INCX 289 KK = KK + ( N - J + 1 ) 290 160 CONTINUE 291 END IF 292 END IF 293 END IF 294* 295 RETURN 296* 297* End of STPMV . 298* 299 END 300