LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine zhpr ( character  UPLO,
integer  N,
double precision  ALPHA,
complex*16, dimension(*)  X,
integer  INCX,
complex*16, dimension(*)  AP 
)

ZHPR

Purpose: 
 ZHPR    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 DOUBLE PRECISION.
           On entry, ALPHA specifies the scalar alpha.
[in]X
          X is COMPLEX*16 array of 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*16 array of 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.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011
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 132 of file zhpr.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: