LAPACK  3.11.0
LAPACK: Linear Algebra PACKage
cherk.f
1 *> \brief \b CHERK
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 CHERK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
12 *
13 * .. Scalar Arguments ..
14 * REAL ALPHA,BETA
15 * INTEGER K,LDA,LDC,N
16 * CHARACTER TRANS,UPLO
17 * ..
18 * .. Array Arguments ..
19 * COMPLEX A(LDA,*),C(LDC,*)
20 * ..
21 *
22 *
23 *> \par Purpose:
24 * =============
25 *>
26 *> \verbatim
27 *>
28 *> CHERK performs one of the hermitian rank k operations
29 *>
30 *> C := alpha*A*A**H + beta*C,
31 *>
32 *> or
33 *>
34 *> C := alpha*A**H*A + beta*C,
35 *>
36 *> where alpha and beta are real scalars, C is an n by n hermitian
37 *> matrix and A is an n by k matrix in the first case and a k by n
38 *> matrix in the second case.
39 *> \endverbatim
40 *
41 * Arguments:
42 * ==========
43 *
44 *> \param[in] UPLO
45 *> \verbatim
46 *> UPLO is CHARACTER*1
47 *> On entry, UPLO specifies whether the upper or lower
48 *> triangular part of the array C is to be referenced as
49 *> follows:
50 *>
51 *> UPLO = 'U' or 'u' Only the upper triangular part of C
52 *> is to be referenced.
53 *>
54 *> UPLO = 'L' or 'l' Only the lower triangular part of C
55 *> is to be referenced.
56 *> \endverbatim
57 *>
58 *> \param[in] TRANS
59 *> \verbatim
60 *> TRANS is CHARACTER*1
61 *> On entry, TRANS specifies the operation to be performed as
62 *> follows:
63 *>
64 *> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C.
65 *>
66 *> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C.
67 *> \endverbatim
68 *>
69 *> \param[in] N
70 *> \verbatim
71 *> N is INTEGER
72 *> On entry, N specifies the order of the matrix C. N must be
73 *> at least zero.
74 *> \endverbatim
75 *>
76 *> \param[in] K
77 *> \verbatim
78 *> K is INTEGER
79 *> On entry with TRANS = 'N' or 'n', K specifies the number
80 *> of columns of the matrix A, and on entry with
81 *> TRANS = 'C' or 'c', K specifies the number of rows of the
82 *> matrix A. K must be at least zero.
83 *> \endverbatim
84 *>
85 *> \param[in] ALPHA
86 *> \verbatim
87 *> ALPHA is REAL
88 *> On entry, ALPHA specifies the scalar alpha.
89 *> \endverbatim
90 *>
91 *> \param[in] A
92 *> \verbatim
93 *> A is COMPLEX array, dimension ( LDA, ka ), where ka is
94 *> k when TRANS = 'N' or 'n', and is n otherwise.
95 *> Before entry with TRANS = 'N' or 'n', the leading n by k
96 *> part of the array A must contain the matrix A, otherwise
97 *> the leading k by n part of the array A must contain the
98 *> matrix A.
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. When TRANS = 'N' or 'n'
106 *> then LDA must be at least max( 1, n ), otherwise LDA must
107 *> be at least max( 1, k ).
108 *> \endverbatim
109 *>
110 *> \param[in] BETA
111 *> \verbatim
112 *> BETA is REAL
113 *> On entry, BETA specifies the scalar beta.
114 *> \endverbatim
115 *>
116 *> \param[in,out] C
117 *> \verbatim
118 *> C is COMPLEX array, dimension ( LDC, N )
119 *> Before entry with UPLO = 'U' or 'u', the leading n by n
120 *> upper triangular part of the array C must contain the upper
121 *> triangular part of the hermitian matrix and the strictly
122 *> lower triangular part of C is not referenced. On exit, the
123 *> upper triangular part of the array C is overwritten by the
124 *> upper triangular part of the updated matrix.
125 *> Before entry with UPLO = 'L' or 'l', the leading n by n
126 *> lower triangular part of the array C must contain the lower
127 *> triangular part of the hermitian matrix and the strictly
128 *> upper triangular part of C is not referenced. On exit, the
129 *> lower triangular part of the array C is overwritten by the
130 *> lower triangular part of the updated matrix.
131 *> Note that the imaginary parts of the diagonal elements need
132 *> not be set, they are assumed to be zero, and on exit they
133 *> are set to zero.
134 *> \endverbatim
135 *>
136 *> \param[in] LDC
137 *> \verbatim
138 *> LDC is INTEGER
139 *> On entry, LDC specifies the first dimension of C as declared
140 *> in the calling (sub) program. LDC must be at least
141 *> max( 1, n ).
142 *> \endverbatim
143 *
144 * Authors:
145 * ========
146 *
147 *> \author Univ. of Tennessee
148 *> \author Univ. of California Berkeley
149 *> \author Univ. of Colorado Denver
150 *> \author NAG Ltd.
151 *
152 *> \ingroup herk
153 *
154 *> \par Further Details:
155 * =====================
156 *>
157 *> \verbatim
158 *>
159 *> Level 3 Blas routine.
160 *>
161 *> -- Written on 8-February-1989.
162 *> Jack Dongarra, Argonne National Laboratory.
163 *> Iain Duff, AERE Harwell.
164 *> Jeremy Du Croz, Numerical Algorithms Group Ltd.
165 *> Sven Hammarling, Numerical Algorithms Group Ltd.
166 *>
167 *> -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1.
168 *> Ed Anderson, Cray Research Inc.
169 *> \endverbatim
170 *>
171 * =====================================================================
172  SUBROUTINE cherk(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
173 *
174 * -- Reference BLAS level3 routine --
175 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
176 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
177 *
178 * .. Scalar Arguments ..
179  REAL ALPHA,BETA
180  INTEGER K,LDA,LDC,N
181  CHARACTER TRANS,UPLO
182 * ..
183 * .. Array Arguments ..
184  COMPLEX A(lda,*),C(ldc,*)
185 * ..
186 *
187 * =====================================================================
188 *
189 * .. External Functions ..
190  LOGICAL LSAME
191  EXTERNAL lsame
192 * ..
193 * .. External Subroutines ..
194  EXTERNAL xerbla
195 * ..
196 * .. Intrinsic Functions ..
197  INTRINSIC cmplx,conjg,max,real
198 * ..
199 * .. Local Scalars ..
200  COMPLEX TEMP
201  REAL RTEMP
202  INTEGER I,INFO,J,L,NROWA
203  LOGICAL UPPER
204 * ..
205 * .. Parameters ..
206  REAL ONE,ZERO
207  parameter(one=1.0e+0,zero=0.0e+0)
208 * ..
209 *
210 * Test the input parameters.
211 *
212  IF (lsame(trans,'N')) THEN
213  nrowa = n
214  ELSE
215  nrowa = k
216  END IF
217  upper = lsame(uplo,'U')
218 *
219  info = 0
220  IF ((.NOT.upper) .AND. (.NOT.lsame(uplo,'L'))) THEN
221  info = 1
222  ELSE IF ((.NOT.lsame(trans,'N')) .AND.
223  + (.NOT.lsame(trans,'C'))) THEN
224  info = 2
225  ELSE IF (n.LT.0) THEN
226  info = 3
227  ELSE IF (k.LT.0) THEN
228  info = 4
229  ELSE IF (lda.LT.max(1,nrowa)) THEN
230  info = 7
231  ELSE IF (ldc.LT.max(1,n)) THEN
232  info = 10
233  END IF
234  IF (info.NE.0) THEN
235  CALL xerbla('CHERK ',info)
236  RETURN
237  END IF
238 *
239 * Quick return if possible.
240 *
241  IF ((n.EQ.0) .OR. (((alpha.EQ.zero).OR.
242  + (k.EQ.0)).AND. (beta.EQ.one))) RETURN
243 *
244 * And when alpha.eq.zero.
245 *
246  IF (alpha.EQ.zero) THEN
247  IF (upper) THEN
248  IF (beta.EQ.zero) THEN
249  DO 20 j = 1,n
250  DO 10 i = 1,j
251  c(i,j) = zero
252  10 CONTINUE
253  20 CONTINUE
254  ELSE
255  DO 40 j = 1,n
256  DO 30 i = 1,j - 1
257  c(i,j) = beta*c(i,j)
258  30 CONTINUE
259  c(j,j) = beta*REAL(c(j,j))
260  40 CONTINUE
261  END IF
262  ELSE
263  IF (beta.EQ.zero) THEN
264  DO 60 j = 1,n
265  DO 50 i = j,n
266  c(i,j) = zero
267  50 CONTINUE
268  60 CONTINUE
269  ELSE
270  DO 80 j = 1,n
271  c(j,j) = beta*REAL(c(j,j))
272  DO 70 i = j + 1,n
273  c(i,j) = beta*c(i,j)
274  70 CONTINUE
275  80 CONTINUE
276  END IF
277  END IF
278  RETURN
279  END IF
280 *
281 * Start the operations.
282 *
283  IF (lsame(trans,'N')) THEN
284 *
285 * Form C := alpha*A*A**H + beta*C.
286 *
287  IF (upper) THEN
288  DO 130 j = 1,n
289  IF (beta.EQ.zero) THEN
290  DO 90 i = 1,j
291  c(i,j) = zero
292  90 CONTINUE
293  ELSE IF (beta.NE.one) THEN
294  DO 100 i = 1,j - 1
295  c(i,j) = beta*c(i,j)
296  100 CONTINUE
297  c(j,j) = beta*REAL(c(j,j))
298  ELSE
299  c(j,j) = REAL(c(j,j))
300  END IF
301  DO 120 l = 1,k
302  IF (a(j,l).NE.cmplx(zero)) THEN
303  temp = alpha*conjg(a(j,l))
304  DO 110 i = 1,j - 1
305  c(i,j) = c(i,j) + temp*a(i,l)
306  110 CONTINUE
307  c(j,j) = REAL(C(J,J)) + REAL(temp*a(i,l))
308  END IF
309  120 CONTINUE
310  130 CONTINUE
311  ELSE
312  DO 180 j = 1,n
313  IF (beta.EQ.zero) THEN
314  DO 140 i = j,n
315  c(i,j) = zero
316  140 CONTINUE
317  ELSE IF (beta.NE.one) THEN
318  c(j,j) = beta*REAL(c(j,j))
319  DO 150 i = j + 1,n
320  c(i,j) = beta*c(i,j)
321  150 CONTINUE
322  ELSE
323  c(j,j) = REAL(c(j,j))
324  END IF
325  DO 170 l = 1,k
326  IF (a(j,l).NE.cmplx(zero)) THEN
327  temp = alpha*conjg(a(j,l))
328  c(j,j) = REAL(C(J,J)) + REAL(temp*a(j,l))
329  DO 160 i = j + 1,n
330  c(i,j) = c(i,j) + temp*a(i,l)
331  160 CONTINUE
332  END IF
333  170 CONTINUE
334  180 CONTINUE
335  END IF
336  ELSE
337 *
338 * Form C := alpha*A**H*A + beta*C.
339 *
340  IF (upper) THEN
341  DO 220 j = 1,n
342  DO 200 i = 1,j - 1
343  temp = zero
344  DO 190 l = 1,k
345  temp = temp + conjg(a(l,i))*a(l,j)
346  190 CONTINUE
347  IF (beta.EQ.zero) THEN
348  c(i,j) = alpha*temp
349  ELSE
350  c(i,j) = alpha*temp + beta*c(i,j)
351  END IF
352  200 CONTINUE
353  rtemp = zero
354  DO 210 l = 1,k
355  rtemp = rtemp + REAL(conjg(a(l,j))*a(l,j))
356  210 CONTINUE
357  IF (beta.EQ.zero) THEN
358  c(j,j) = alpha*rtemp
359  ELSE
360  c(j,j) = alpha*rtemp + beta*REAL(c(j,j))
361  END IF
362  220 CONTINUE
363  ELSE
364  DO 260 j = 1,n
365  rtemp = zero
366  DO 230 l = 1,k
367  rtemp = rtemp + REAL(conjg(a(l,j))*a(l,j))
368  230 CONTINUE
369  IF (beta.EQ.zero) THEN
370  c(j,j) = alpha*rtemp
371  ELSE
372  c(j,j) = alpha*rtemp + beta*REAL(c(j,j))
373  END IF
374  DO 250 i = j + 1,n
375  temp = zero
376  DO 240 l = 1,k
377  temp = temp + conjg(a(l,i))*a(l,j)
378  240 CONTINUE
379  IF (beta.EQ.zero) THEN
380  c(i,j) = alpha*temp
381  ELSE
382  c(i,j) = alpha*temp + beta*c(i,j)
383  END IF
384  250 CONTINUE
385  260 CONTINUE
386  END IF
387  END IF
388 *
389  RETURN
390 *
391 * End of CHERK
392 *
393  END
cherk
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
Definition: cherk.f:173
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60