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
