1 SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP) 2* .. Scalar Arguments .. 3 REAL ALPHA 4 INTEGER INCX,N 5 CHARACTER UPLO 6* .. 7* .. Array Arguments .. 8 REAL AP(*),X(*) 9* .. 10* 11* Purpose 12* ======= 13* 14* SSPR performs the symmetric rank 1 operation 15* 16* A := alpha*x*x' + A, 17* 18* where alpha is a real scalar, x is an n element vector and A is an 19* n by n symmetric matrix, supplied in packed form. 20* 21* Arguments 22* ========== 23* 24* UPLO - CHARACTER*1. 25* On entry, UPLO specifies whether the upper or lower 26* triangular part of the matrix A is supplied in the packed 27* array AP as follows: 28* 29* UPLO = 'U' or 'u' The upper triangular part of A is 30* supplied in AP. 31* 32* UPLO = 'L' or 'l' The lower triangular part of A is 33* supplied in AP. 34* 35* Unchanged on exit. 36* 37* N - INTEGER. 38* On entry, N specifies the order of the matrix A. 39* N must be at least zero. 40* Unchanged on exit. 41* 42* ALPHA - REAL . 43* On entry, ALPHA specifies the scalar alpha. 44* Unchanged on exit. 45* 46* X - REAL array of dimension at least 47* ( 1 + ( n - 1 )*abs( INCX ) ). 48* Before entry, the incremented array X must contain the n 49* element vector x. 50* Unchanged on exit. 51* 52* INCX - INTEGER. 53* On entry, INCX specifies the increment for the elements of 54* X. INCX must not be zero. 55* Unchanged on exit. 56* 57* AP - REAL array of DIMENSION at least 58* ( ( n*( n + 1 ) )/2 ). 59* Before entry with UPLO = 'U' or 'u', the array AP must 60* contain the upper triangular part of the symmetric matrix 61* packed sequentially, column by column, so that AP( 1 ) 62* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) 63* and a( 2, 2 ) respectively, and so on. On exit, the array 64* AP is overwritten by the upper triangular part of the 65* updated matrix. 66* Before entry with UPLO = 'L' or 'l', the array AP must 67* contain the lower triangular part of the symmetric matrix 68* packed sequentially, column by column, so that AP( 1 ) 69* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) 70* and a( 3, 1 ) respectively, and so on. On exit, the array 71* AP is overwritten by the lower triangular part of the 72* updated matrix. 73* 74* Further Details 75* =============== 76* 77* Level 2 Blas routine. 78* 79* -- Written on 22-October-1986. 80* Jack Dongarra, Argonne National Lab. 81* Jeremy Du Croz, Nag Central Office. 82* Sven Hammarling, Nag Central Office. 83* Richard Hanson, Sandia National Labs. 84* 85* ===================================================================== 86* 87* .. Parameters .. 88 REAL ZERO 89 PARAMETER (ZERO=0.0E+0) 90* .. 91* .. Local Scalars .. 92 REAL TEMP 93 INTEGER I,INFO,IX,J,JX,K,KK,KX 94* .. 95* .. External Functions .. 96 LOGICAL LSAME 97 EXTERNAL LSAME 98* .. 99* .. External Subroutines .. 100 EXTERNAL XERBLA 101* .. 102* 103* Test the input parameters. 104* 105 INFO = 0 106 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN 107 INFO = 1 108 ELSE IF (N.LT.0) THEN 109 INFO = 2 110 ELSE IF (INCX.EQ.0) THEN 111 INFO = 5 112 END IF 113 IF (INFO.NE.0) THEN 114 CALL XERBLA('SSPR ',INFO) 115 RETURN 116 END IF 117* 118* Quick return if possible. 119* 120 IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN 121* 122* Set the start point in X if the increment is not unity. 123* 124 IF (INCX.LE.0) THEN 125 KX = 1 - (N-1)*INCX 126 ELSE IF (INCX.NE.1) THEN 127 KX = 1 128 END IF 129* 130* Start the operations. In this version the elements of the array AP 131* are accessed sequentially with one pass through AP. 132* 133 KK = 1 134 IF (LSAME(UPLO,'U')) THEN 135* 136* Form A when upper triangle is stored in AP. 137* 138 IF (INCX.EQ.1) THEN 139 DO 20 J = 1,N 140 IF (X(J).NE.ZERO) THEN 141 TEMP = ALPHA*X(J) 142 K = KK 143 DO 10 I = 1,J 144 AP(K) = AP(K) + X(I)*TEMP 145 K = K + 1 146 10 CONTINUE 147 END IF 148 KK = KK + J 149 20 CONTINUE 150 ELSE 151 JX = KX 152 DO 40 J = 1,N 153 IF (X(JX).NE.ZERO) THEN 154 TEMP = ALPHA*X(JX) 155 IX = KX 156 DO 30 K = KK,KK + J - 1 157 AP(K) = AP(K) + X(IX)*TEMP 158 IX = IX + INCX 159 30 CONTINUE 160 END IF 161 JX = JX + INCX 162 KK = KK + J 163 40 CONTINUE 164 END IF 165 ELSE 166* 167* Form A when lower triangle is stored in AP. 168* 169 IF (INCX.EQ.1) THEN 170 DO 60 J = 1,N 171 IF (X(J).NE.ZERO) THEN 172 TEMP = ALPHA*X(J) 173 K = KK 174 DO 50 I = J,N 175 AP(K) = AP(K) + X(I)*TEMP 176 K = K + 1 177 50 CONTINUE 178 END IF 179 KK = KK + N - J + 1 180 60 CONTINUE 181 ELSE 182 JX = KX 183 DO 80 J = 1,N 184 IF (X(JX).NE.ZERO) THEN 185 TEMP = ALPHA*X(JX) 186 IX = JX 187 DO 70 K = KK,KK + N - J 188 AP(K) = AP(K) + X(IX)*TEMP 189 IX = IX + INCX 190 70 CONTINUE 191 END IF 192 JX = JX + INCX 193 KK = KK + N - J + 1 194 80 CONTINUE 195 END IF 196 END IF 197* 198 RETURN 199* 200* End of SSPR . 201* 202 END 203