 LAPACK  3.10.0 LAPACK: Linear Algebra PACKage

## ◆ chpr()

 subroutine chpr ( character UPLO, integer N, real ALPHA, complex, dimension(*) X, integer INCX, complex, dimension(*) AP )

CHPR

Purpose:
``` CHPR    performs the hermitian rank 1 operation

A := alpha*x*x**H + A,

where alpha is a real scalar, x is an n element vector and A is an
n by n hermitian matrix, supplied in packed form.```
Parameters
 [in] UPLO ``` UPLO is CHARACTER*1 On entry, UPLO specifies whether the upper or lower triangular part of the matrix A is supplied in the packed array AP as follows: UPLO = 'U' or 'u' The upper triangular part of A is supplied in AP. UPLO = 'L' or 'l' The lower triangular part of A is supplied in AP.``` [in] N ``` N is INTEGER On entry, N specifies the order of the matrix A. N must be at least zero.``` [in] ALPHA ``` ALPHA is REAL On entry, ALPHA specifies the scalar alpha.``` [in] X ``` X is COMPLEX array, dimension at least ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremented array X must contain the n element vector x.``` [in] INCX ``` INCX is INTEGER On entry, INCX specifies the increment for the elements of X. INCX must not be zero.``` [in,out] AP ``` AP is COMPLEX array, dimension at least ( ( n*( n + 1 ) )/2 ). Before entry with UPLO = 'U' or 'u', the array AP must contain the upper triangular part of the hermitian matrix packed sequentially, column by column, so that AP( 1 ) contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) respectively, and so on. On exit, the array AP is overwritten by the upper triangular part of the updated matrix. Before entry with UPLO = 'L' or 'l', the array AP must contain the lower triangular part of the hermitian matrix packed sequentially, column by column, so that AP( 1 ) contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) respectively, and so on. On exit, the array AP is overwritten by the lower triangular part of the updated matrix. Note that the imaginary parts of the diagonal elements need not be set, they are assumed to be zero, and on exit they are set to zero.```
Further Details:
```  Level 2 Blas routine.

-- Written on 22-October-1986.
Jack Dongarra, Argonne National Lab.
Jeremy Du Croz, Nag Central Office.
Sven Hammarling, Nag Central Office.
Richard Hanson, Sandia National Labs.```

Definition at line 129 of file chpr.f.

130 *
131 * -- Reference BLAS level2 routine --
132 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
133 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
134 *
135 * .. Scalar Arguments ..
136  REAL ALPHA
137  INTEGER INCX,N
138  CHARACTER UPLO
139 * ..
140 * .. Array Arguments ..
141  COMPLEX AP(*),X(*)
142 * ..
143 *
144 * =====================================================================
145 *
146 * .. Parameters ..
147  COMPLEX ZERO
148  parameter(zero= (0.0e+0,0.0e+0))
149 * ..
150 * .. Local Scalars ..
151  COMPLEX TEMP
152  INTEGER I,INFO,IX,J,JX,K,KK,KX
153 * ..
154 * .. External Functions ..
155  LOGICAL LSAME
156  EXTERNAL lsame
157 * ..
158 * .. External Subroutines ..
159  EXTERNAL xerbla
160 * ..
161 * .. Intrinsic Functions ..
162  INTRINSIC conjg,real
163 * ..
164 *
165 * Test the input parameters.
166 *
167  info = 0
168  IF (.NOT.lsame(uplo,'U') .AND. .NOT.lsame(uplo,'L')) THEN
169  info = 1
170  ELSE IF (n.LT.0) THEN
171  info = 2
172  ELSE IF (incx.EQ.0) THEN
173  info = 5
174  END IF
175  IF (info.NE.0) THEN
176  CALL xerbla('CHPR ',info)
177  RETURN
178  END IF
179 *
180 * Quick return if possible.
181 *
182  IF ((n.EQ.0) .OR. (alpha.EQ.real(zero))) RETURN
183 *
184 * Set the start point in X if the increment is not unity.
185 *
186  IF (incx.LE.0) THEN
187  kx = 1 - (n-1)*incx
188  ELSE IF (incx.NE.1) THEN
189  kx = 1
190  END IF
191 *
192 * Start the operations. In this version the elements of the array AP
193 * are accessed sequentially with one pass through AP.
194 *
195  kk = 1
196  IF (lsame(uplo,'U')) THEN
197 *
198 * Form A when upper triangle is stored in AP.
199 *
200  IF (incx.EQ.1) THEN
201  DO 20 j = 1,n
202  IF (x(j).NE.zero) THEN
203  temp = alpha*conjg(x(j))
204  k = kk
205  DO 10 i = 1,j - 1
206  ap(k) = ap(k) + x(i)*temp
207  k = k + 1
208  10 CONTINUE
209  ap(kk+j-1) = real(ap(kk+j-1)) + real(x(j)*temp)
210  ELSE
211  ap(kk+j-1) = real(ap(kk+j-1))
212  END IF
213  kk = kk + j
214  20 CONTINUE
215  ELSE
216  jx = kx
217  DO 40 j = 1,n
218  IF (x(jx).NE.zero) THEN
219  temp = alpha*conjg(x(jx))
220  ix = kx
221  DO 30 k = kk,kk + j - 2
222  ap(k) = ap(k) + x(ix)*temp
223  ix = ix + incx
224  30 CONTINUE
225  ap(kk+j-1) = real(ap(kk+j-1)) + real(x(jx)*temp)
226  ELSE
227  ap(kk+j-1) = real(ap(kk+j-1))
228  END IF
229  jx = jx + incx
230  kk = kk + j
231  40 CONTINUE
232  END IF
233  ELSE
234 *
235 * Form A when lower triangle is stored in AP.
236 *
237  IF (incx.EQ.1) THEN
238  DO 60 j = 1,n
239  IF (x(j).NE.zero) THEN
240  temp = alpha*conjg(x(j))
241  ap(kk) = real(ap(kk)) + real(temp*x(j))
242  k = kk + 1
243  DO 50 i = j + 1,n
244  ap(k) = ap(k) + x(i)*temp
245  k = k + 1
246  50 CONTINUE
247  ELSE
248  ap(kk) = real(ap(kk))
249  END IF
250  kk = kk + n - j + 1
251  60 CONTINUE
252  ELSE
253  jx = kx
254  DO 80 j = 1,n
255  IF (x(jx).NE.zero) THEN
256  temp = alpha*conjg(x(jx))
257  ap(kk) = real(ap(kk)) + real(temp*x(jx))
258  ix = jx
259  DO 70 k = kk + 1,kk + n - j
260  ix = ix + incx
261  ap(k) = ap(k) + x(ix)*temp
262  70 CONTINUE
263  ELSE
264  ap(kk) = real(ap(kk))
265  END IF
266  jx = jx + incx
267  kk = kk + n - j + 1
268  80 CONTINUE
269  END IF
270  END IF
271 *
272  RETURN
273 *
274 * End of CHPR
275 *
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
Here is the call graph for this function:
Here is the caller graph for this function: