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**T + 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
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**T + 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