LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
cher.f
Go to the documentation of this file.
1 *> \brief \b CHER
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE CHER(UPLO,N,ALPHA,X,INCX,A,LDA)
12 *
13 * .. Scalar Arguments ..
14 * REAL ALPHA
15 * INTEGER INCX,LDA,N
16 * CHARACTER UPLO
17 * ..
18 * .. Array Arguments ..
19 * COMPLEX A(LDA,*),X(*)
20 * ..
21 *
22 *
23 *> \par Purpose:
24 * =============
25 *>
26 *> \verbatim
27 *>
28 *> CHER performs the hermitian rank 1 operation
29 *>
30 *> A := alpha*x*x**H + A,
31 *>
32 *> where alpha is a real scalar, x is an n element vector and A is an
33 *> n by n hermitian matrix.
34 *> \endverbatim
35 *
36 * Arguments:
37 * ==========
38 *
39 *> \param[in] UPLO
40 *> \verbatim
41 *> UPLO is CHARACTER*1
42 *> On entry, UPLO specifies whether the upper or lower
43 *> triangular part of the array A is to be referenced as
44 *> follows:
45 *>
46 *> UPLO = 'U' or 'u' Only the upper triangular part of A
47 *> is to be referenced.
48 *>
49 *> UPLO = 'L' or 'l' Only the lower triangular part of A
50 *> is to be referenced.
51 *> \endverbatim
52 *>
53 *> \param[in] N
54 *> \verbatim
55 *> N is INTEGER
56 *> On entry, N specifies the order of the matrix A.
57 *> N must be at least zero.
58 *> \endverbatim
59 *>
60 *> \param[in] ALPHA
61 *> \verbatim
62 *> ALPHA is REAL
63 *> On entry, ALPHA specifies the scalar alpha.
64 *> \endverbatim
65 *>
66 *> \param[in] X
67 *> \verbatim
68 *> X is COMPLEX array of dimension at least
69 *> ( 1 + ( n - 1 )*abs( INCX ) ).
70 *> Before entry, the incremented array X must contain the n
71 *> element vector x.
72 *> \endverbatim
73 *>
74 *> \param[in] INCX
75 *> \verbatim
76 *> INCX is INTEGER
77 *> On entry, INCX specifies the increment for the elements of
78 *> X. INCX must not be zero.
79 *> \endverbatim
80 *>
81 *> \param[in,out] A
82 *> \verbatim
83 *> A is COMPLEX array of DIMENSION ( LDA, n ).
84 *> Before entry with UPLO = 'U' or 'u', the leading n by n
85 *> upper triangular part of the array A must contain the upper
86 *> triangular part of the hermitian matrix and the strictly
87 *> lower triangular part of A is not referenced. On exit, the
88 *> upper triangular part of the array A is overwritten by the
89 *> upper triangular part of the updated matrix.
90 *> Before entry with UPLO = 'L' or 'l', the leading n by n
91 *> lower triangular part of the array A must contain the lower
92 *> triangular part of the hermitian matrix and the strictly
93 *> upper triangular part of A is not referenced. On exit, the
94 *> lower triangular part of the array A is overwritten by the
95 *> lower triangular part of the updated matrix.
96 *> Note that the imaginary parts of the diagonal elements need
97 *> not be set, they are assumed to be zero, and on exit they
98 *> are set to zero.
99 *> \endverbatim
100 *>
101 *> \param[in] LDA
102 *> \verbatim
103 *> LDA is INTEGER
104 *> On entry, LDA specifies the first dimension of A as declared
105 *> in the calling (sub) program. LDA must be at least
106 *> max( 1, n ).
107 *> \endverbatim
108 *
109 * Authors:
110 * ========
111 *
112 *> \author Univ. of Tennessee
113 *> \author Univ. of California Berkeley
114 *> \author Univ. of Colorado Denver
115 *> \author NAG Ltd.
116 *
117 *> \date November 2011
118 *
119 *> \ingroup complex_blas_level2
120 *
121 *> \par Further Details:
122 * =====================
123 *>
124 *> \verbatim
125 *>
126 *> Level 2 Blas routine.
127 *>
128 *> -- Written on 22-October-1986.
129 *> Jack Dongarra, Argonne National Lab.
130 *> Jeremy Du Croz, Nag Central Office.
131 *> Sven Hammarling, Nag Central Office.
132 *> Richard Hanson, Sandia National Labs.
133 *> \endverbatim
134 *>
135 * =====================================================================
136  SUBROUTINE cher(UPLO,N,ALPHA,X,INCX,A,LDA)
137 *
138 * -- Reference BLAS level2 routine (version 3.4.0) --
139 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
140 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
141 * November 2011
142 *
143 * .. Scalar Arguments ..
144  REAL alpha
145  INTEGER incx,lda,n
146  CHARACTER uplo
147 * ..
148 * .. Array Arguments ..
149  COMPLEX a(lda,*),x(*)
150 * ..
151 *
152 * =====================================================================
153 *
154 * .. Parameters ..
155  COMPLEX zero
156  parameter(zero= (0.0e+0,0.0e+0))
157 * ..
158 * .. Local Scalars ..
159  COMPLEX temp
160  INTEGER i,info,ix,j,jx,kx
161 * ..
162 * .. External Functions ..
163  LOGICAL lsame
164  EXTERNAL lsame
165 * ..
166 * .. External Subroutines ..
167  EXTERNAL xerbla
168 * ..
169 * .. Intrinsic Functions ..
170  INTRINSIC conjg,max,real
171 * ..
172 *
173 * Test the input parameters.
174 *
175  info = 0
176  IF (.NOT.lsame(uplo,'U') .AND. .NOT.lsame(uplo,'L')) THEN
177  info = 1
178  ELSE IF (n.LT.0) THEN
179  info = 2
180  ELSE IF (incx.EQ.0) THEN
181  info = 5
182  ELSE IF (lda.LT.max(1,n)) THEN
183  info = 7
184  END IF
185  IF (info.NE.0) THEN
186  CALL xerbla('CHER ',info)
187  RETURN
188  END IF
189 *
190 * Quick return if possible.
191 *
192  IF ((n.EQ.0) .OR. (alpha.EQ.REAL(zero))) return
193 *
194 * Set the start point in X if the increment is not unity.
195 *
196  IF (incx.LE.0) THEN
197  kx = 1 - (n-1)*incx
198  ELSE IF (incx.NE.1) THEN
199  kx = 1
200  END IF
201 *
202 * Start the operations. In this version the elements of A are
203 * accessed sequentially with one pass through the triangular part
204 * of A.
205 *
206  IF (lsame(uplo,'U')) THEN
207 *
208 * Form A when A is stored in upper triangle.
209 *
210  IF (incx.EQ.1) THEN
211  DO 20 j = 1,n
212  IF (x(j).NE.zero) THEN
213  temp = alpha*conjg(x(j))
214  DO 10 i = 1,j - 1
215  a(i,j) = a(i,j) + x(i)*temp
216  10 CONTINUE
217  a(j,j) = REAL(A(J,J)) + REAL(x(j)*temp)
218  ELSE
219  a(j,j) = REAL(a(j,j))
220  END IF
221  20 CONTINUE
222  ELSE
223  jx = kx
224  DO 40 j = 1,n
225  IF (x(jx).NE.zero) THEN
226  temp = alpha*conjg(x(jx))
227  ix = kx
228  DO 30 i = 1,j - 1
229  a(i,j) = a(i,j) + x(ix)*temp
230  ix = ix + incx
231  30 CONTINUE
232  a(j,j) = REAL(A(J,J)) + REAL(x(jx)*temp)
233  ELSE
234  a(j,j) = REAL(a(j,j))
235  END IF
236  jx = jx + incx
237  40 CONTINUE
238  END IF
239  ELSE
240 *
241 * Form A when A is stored in lower triangle.
242 *
243  IF (incx.EQ.1) THEN
244  DO 60 j = 1,n
245  IF (x(j).NE.zero) THEN
246  temp = alpha*conjg(x(j))
247  a(j,j) = REAL(A(J,J)) + REAL(temp*x(j))
248  DO 50 i = j + 1,n
249  a(i,j) = a(i,j) + x(i)*temp
250  50 CONTINUE
251  ELSE
252  a(j,j) = REAL(a(j,j))
253  END IF
254  60 CONTINUE
255  ELSE
256  jx = kx
257  DO 80 j = 1,n
258  IF (x(jx).NE.zero) THEN
259  temp = alpha*conjg(x(jx))
260  a(j,j) = REAL(A(J,J)) + REAL(temp*x(jx))
261  ix = jx
262  DO 70 i = j + 1,n
263  ix = ix + incx
264  a(i,j) = a(i,j) + x(ix)*temp
265  70 CONTINUE
266  ELSE
267  a(j,j) = REAL(a(j,j))
268  END IF
269  jx = jx + incx
270  80 CONTINUE
271  END IF
272  END IF
273 *
274  RETURN
275 *
276 * End of CHER .
277 *
278  END