1 SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
2 * .. Scalar Arguments ..
3 DOUBLE PRECISION ALPHA
4 INTEGER INCX,INCY,N
5 CHARACTER UPLO
6 * ..
7 * .. Array Arguments ..
8 DOUBLE PRECISION AP(*),X(*),Y(*)
9 * ..
10 *
11 * Purpose
12 * =======
13 *
14 * DSPR2 performs the symmetric rank 2 operation
15 *
16 * A := alpha*x*y**T + alpha*y*x**T + A,
17 *
18 * where alpha is a scalar, x and y are n element vectors 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 - DOUBLE PRECISION.
43 * On entry, ALPHA specifies the scalar alpha.
44 * Unchanged on exit.
45 *
46 * X - DOUBLE PRECISION 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 * Y - DOUBLE PRECISION array of dimension at least
58 * ( 1 + ( n - 1 )*abs( INCY ) ).
59 * Before entry, the incremented array Y must contain the n
60 * element vector y.
61 * Unchanged on exit.
62 *
63 * INCY - INTEGER.
64 * On entry, INCY specifies the increment for the elements of
65 * Y. INCY must not be zero.
66 * Unchanged on exit.
67 *
68 * AP - DOUBLE PRECISION array of DIMENSION at least
69 * ( ( n*( n + 1 ) )/2 ).
70 * Before entry with UPLO = 'U' or 'u', the array AP must
71 * contain the upper triangular part of the symmetric matrix
72 * packed sequentially, column by column, so that AP( 1 )
73 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
74 * and a( 2, 2 ) respectively, and so on. On exit, the array
75 * AP is overwritten by the upper triangular part of the
76 * updated matrix.
77 * Before entry with UPLO = 'L' or 'l', the array AP must
78 * contain the lower triangular part of the symmetric matrix
79 * packed sequentially, column by column, so that AP( 1 )
80 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
81 * and a( 3, 1 ) respectively, and so on. On exit, the array
82 * AP is overwritten by the lower triangular part of the
83 * updated matrix.
84 *
85 * Further Details
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 *
98 * .. Parameters ..
99 DOUBLE PRECISION ZERO
100 PARAMETER (ZERO=0.0D+0)
101 * ..
102 * .. Local Scalars ..
103 DOUBLE PRECISION TEMP1,TEMP2
104 INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
105 * ..
106 * .. External Functions ..
107 LOGICAL LSAME
108 EXTERNAL LSAME
109 * ..
110 * .. External Subroutines ..
111 EXTERNAL XERBLA
112 * ..
113 *
114 * Test the input parameters.
115 *
116 INFO = 0
117 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
118 INFO = 1
119 ELSE IF (N.LT.0) THEN
120 INFO = 2
121 ELSE IF (INCX.EQ.0) THEN
122 INFO = 5
123 ELSE IF (INCY.EQ.0) THEN
124 INFO = 7
125 END IF
126 IF (INFO.NE.0) THEN
127 CALL XERBLA('DSPR2 ',INFO)
128 RETURN
129 END IF
130 *
131 * Quick return if possible.
132 *
133 IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
134 *
135 * Set up the start points in X and Y if the increments are not both
136 * unity.
137 *
138 IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
139 IF (INCX.GT.0) THEN
140 KX = 1
141 ELSE
142 KX = 1 - (N-1)*INCX
143 END IF
144 IF (INCY.GT.0) THEN
145 KY = 1
146 ELSE
147 KY = 1 - (N-1)*INCY
148 END IF
149 JX = KX
150 JY = KY
151 END IF
152 *
153 * Start the operations. In this version the elements of the array AP
154 * are accessed sequentially with one pass through AP.
155 *
156 KK = 1
157 IF (LSAME(UPLO,'U')) THEN
158 *
159 * Form A when upper triangle is stored in AP.
160 *
161 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
162 DO 20 J = 1,N
163 IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
164 TEMP1 = ALPHA*Y(J)
165 TEMP2 = ALPHA*X(J)
166 K = KK
167 DO 10 I = 1,J
168 AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
169 K = K + 1
170 10 CONTINUE
171 END IF
172 KK = KK + J
173 20 CONTINUE
174 ELSE
175 DO 40 J = 1,N
176 IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
177 TEMP1 = ALPHA*Y(JY)
178 TEMP2 = ALPHA*X(JX)
179 IX = KX
180 IY = KY
181 DO 30 K = KK,KK + J - 1
182 AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
183 IX = IX + INCX
184 IY = IY + INCY
185 30 CONTINUE
186 END IF
187 JX = JX + INCX
188 JY = JY + INCY
189 KK = KK + J
190 40 CONTINUE
191 END IF
192 ELSE
193 *
194 * Form A when lower triangle is stored in AP.
195 *
196 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
197 DO 60 J = 1,N
198 IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
199 TEMP1 = ALPHA*Y(J)
200 TEMP2 = ALPHA*X(J)
201 K = KK
202 DO 50 I = J,N
203 AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
204 K = K + 1
205 50 CONTINUE
206 END IF
207 KK = KK + N - J + 1
208 60 CONTINUE
209 ELSE
210 DO 80 J = 1,N
211 IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
212 TEMP1 = ALPHA*Y(JY)
213 TEMP2 = ALPHA*X(JX)
214 IX = JX
215 IY = JY
216 DO 70 K = KK,KK + N - J
217 AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
218 IX = IX + INCX
219 IY = IY + INCY
220 70 CONTINUE
221 END IF
222 JX = JX + INCX
223 JY = JY + INCY
224 KK = KK + N - J + 1
225 80 CONTINUE
226 END IF
227 END IF
228 *
229 RETURN
230 *
231 * End of DSPR2 .
232 *
233 END
2 * .. Scalar Arguments ..
3 DOUBLE PRECISION ALPHA
4 INTEGER INCX,INCY,N
5 CHARACTER UPLO
6 * ..
7 * .. Array Arguments ..
8 DOUBLE PRECISION AP(*),X(*),Y(*)
9 * ..
10 *
11 * Purpose
12 * =======
13 *
14 * DSPR2 performs the symmetric rank 2 operation
15 *
16 * A := alpha*x*y**T + alpha*y*x**T + A,
17 *
18 * where alpha is a scalar, x and y are n element vectors 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 - DOUBLE PRECISION.
43 * On entry, ALPHA specifies the scalar alpha.
44 * Unchanged on exit.
45 *
46 * X - DOUBLE PRECISION 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 * Y - DOUBLE PRECISION array of dimension at least
58 * ( 1 + ( n - 1 )*abs( INCY ) ).
59 * Before entry, the incremented array Y must contain the n
60 * element vector y.
61 * Unchanged on exit.
62 *
63 * INCY - INTEGER.
64 * On entry, INCY specifies the increment for the elements of
65 * Y. INCY must not be zero.
66 * Unchanged on exit.
67 *
68 * AP - DOUBLE PRECISION array of DIMENSION at least
69 * ( ( n*( n + 1 ) )/2 ).
70 * Before entry with UPLO = 'U' or 'u', the array AP must
71 * contain the upper triangular part of the symmetric matrix
72 * packed sequentially, column by column, so that AP( 1 )
73 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
74 * and a( 2, 2 ) respectively, and so on. On exit, the array
75 * AP is overwritten by the upper triangular part of the
76 * updated matrix.
77 * Before entry with UPLO = 'L' or 'l', the array AP must
78 * contain the lower triangular part of the symmetric matrix
79 * packed sequentially, column by column, so that AP( 1 )
80 * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
81 * and a( 3, 1 ) respectively, and so on. On exit, the array
82 * AP is overwritten by the lower triangular part of the
83 * updated matrix.
84 *
85 * Further Details
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 *
98 * .. Parameters ..
99 DOUBLE PRECISION ZERO
100 PARAMETER (ZERO=0.0D+0)
101 * ..
102 * .. Local Scalars ..
103 DOUBLE PRECISION TEMP1,TEMP2
104 INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
105 * ..
106 * .. External Functions ..
107 LOGICAL LSAME
108 EXTERNAL LSAME
109 * ..
110 * .. External Subroutines ..
111 EXTERNAL XERBLA
112 * ..
113 *
114 * Test the input parameters.
115 *
116 INFO = 0
117 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
118 INFO = 1
119 ELSE IF (N.LT.0) THEN
120 INFO = 2
121 ELSE IF (INCX.EQ.0) THEN
122 INFO = 5
123 ELSE IF (INCY.EQ.0) THEN
124 INFO = 7
125 END IF
126 IF (INFO.NE.0) THEN
127 CALL XERBLA('DSPR2 ',INFO)
128 RETURN
129 END IF
130 *
131 * Quick return if possible.
132 *
133 IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
134 *
135 * Set up the start points in X and Y if the increments are not both
136 * unity.
137 *
138 IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
139 IF (INCX.GT.0) THEN
140 KX = 1
141 ELSE
142 KX = 1 - (N-1)*INCX
143 END IF
144 IF (INCY.GT.0) THEN
145 KY = 1
146 ELSE
147 KY = 1 - (N-1)*INCY
148 END IF
149 JX = KX
150 JY = KY
151 END IF
152 *
153 * Start the operations. In this version the elements of the array AP
154 * are accessed sequentially with one pass through AP.
155 *
156 KK = 1
157 IF (LSAME(UPLO,'U')) THEN
158 *
159 * Form A when upper triangle is stored in AP.
160 *
161 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
162 DO 20 J = 1,N
163 IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
164 TEMP1 = ALPHA*Y(J)
165 TEMP2 = ALPHA*X(J)
166 K = KK
167 DO 10 I = 1,J
168 AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
169 K = K + 1
170 10 CONTINUE
171 END IF
172 KK = KK + J
173 20 CONTINUE
174 ELSE
175 DO 40 J = 1,N
176 IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
177 TEMP1 = ALPHA*Y(JY)
178 TEMP2 = ALPHA*X(JX)
179 IX = KX
180 IY = KY
181 DO 30 K = KK,KK + J - 1
182 AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
183 IX = IX + INCX
184 IY = IY + INCY
185 30 CONTINUE
186 END IF
187 JX = JX + INCX
188 JY = JY + INCY
189 KK = KK + J
190 40 CONTINUE
191 END IF
192 ELSE
193 *
194 * Form A when lower triangle is stored in AP.
195 *
196 IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
197 DO 60 J = 1,N
198 IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
199 TEMP1 = ALPHA*Y(J)
200 TEMP2 = ALPHA*X(J)
201 K = KK
202 DO 50 I = J,N
203 AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
204 K = K + 1
205 50 CONTINUE
206 END IF
207 KK = KK + N - J + 1
208 60 CONTINUE
209 ELSE
210 DO 80 J = 1,N
211 IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
212 TEMP1 = ALPHA*Y(JY)
213 TEMP2 = ALPHA*X(JX)
214 IX = JX
215 IY = JY
216 DO 70 K = KK,KK + N - J
217 AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
218 IX = IX + INCX
219 IY = IY + INCY
220 70 CONTINUE
221 END IF
222 JX = JX + INCX
223 JY = JY + INCY
224 KK = KK + N - J + 1
225 80 CONTINUE
226 END IF
227 END IF
228 *
229 RETURN
230 *
231 * End of DSPR2 .
232 *
233 END