LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
chfrk.f
Go to the documentation of this file.
1 *> \brief \b CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download CHFRK + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chfrk.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chfrk.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chfrk.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
22 * C )
23 *
24 * .. Scalar Arguments ..
25 * REAL ALPHA, BETA
26 * INTEGER K, LDA, N
27 * CHARACTER TRANS, TRANSR, UPLO
28 * ..
29 * .. Array Arguments ..
30 * COMPLEX A( LDA, * ), C( * )
31 * ..
32 *
33 *
34 *> \par Purpose:
35 * =============
36 *>
37 *> \verbatim
38 *>
39 *> Level 3 BLAS like routine for C in RFP Format.
40 *>
41 *> CHFRK performs one of the Hermitian rank--k operations
42 *>
43 *> C := alpha*A*A**H + beta*C,
44 *>
45 *> or
46 *>
47 *> C := alpha*A**H*A + beta*C,
48 *>
49 *> where alpha and beta are real scalars, C is an n--by--n Hermitian
50 *> matrix and A is an n--by--k matrix in the first case and a k--by--n
51 *> matrix in the second case.
52 *> \endverbatim
53 *
54 * Arguments:
55 * ==========
56 *
57 *> \param[in] TRANSR
58 *> \verbatim
59 *> TRANSR is CHARACTER*1
60 *> = 'N': The Normal Form of RFP A is stored;
61 *> = 'C': The Conjugate-transpose Form of RFP A is stored.
62 *> \endverbatim
63 *>
64 *> \param[in] UPLO
65 *> \verbatim
66 *> UPLO is CHARACTER*1
67 *> On entry, UPLO specifies whether the upper or lower
68 *> triangular part of the array C is to be referenced as
69 *> follows:
70 *>
71 *> UPLO = 'U' or 'u' Only the upper triangular part of C
72 *> is to be referenced.
73 *>
74 *> UPLO = 'L' or 'l' Only the lower triangular part of C
75 *> is to be referenced.
76 *>
77 *> Unchanged on exit.
78 *> \endverbatim
79 *>
80 *> \param[in] TRANS
81 *> \verbatim
82 *> TRANS is CHARACTER*1
83 *> On entry, TRANS specifies the operation to be performed as
84 *> follows:
85 *>
86 *> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C.
87 *>
88 *> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C.
89 *>
90 *> Unchanged on exit.
91 *> \endverbatim
92 *>
93 *> \param[in] N
94 *> \verbatim
95 *> N is INTEGER
96 *> On entry, N specifies the order of the matrix C. N must be
97 *> at least zero.
98 *> Unchanged on exit.
99 *> \endverbatim
100 *>
101 *> \param[in] K
102 *> \verbatim
103 *> K is INTEGER
104 *> On entry with TRANS = 'N' or 'n', K specifies the number
105 *> of columns of the matrix A, and on entry with
106 *> TRANS = 'C' or 'c', K specifies the number of rows of the
107 *> matrix A. K must be at least zero.
108 *> Unchanged on exit.
109 *> \endverbatim
110 *>
111 *> \param[in] ALPHA
112 *> \verbatim
113 *> ALPHA is REAL
114 *> On entry, ALPHA specifies the scalar alpha.
115 *> Unchanged on exit.
116 *> \endverbatim
117 *>
118 *> \param[in] A
119 *> \verbatim
120 *> A is COMPLEX array, dimension (LDA,ka)
121 *> where KA
122 *> is K when TRANS = 'N' or 'n', and is N otherwise. Before
123 *> entry with TRANS = 'N' or 'n', the leading N--by--K part of
124 *> the array A must contain the matrix A, otherwise the leading
125 *> K--by--N part of the array A must contain the matrix A.
126 *> Unchanged on exit.
127 *> \endverbatim
128 *>
129 *> \param[in] LDA
130 *> \verbatim
131 *> LDA is INTEGER
132 *> On entry, LDA specifies the first dimension of A as declared
133 *> in the calling (sub) program. When TRANS = 'N' or 'n'
134 *> then LDA must be at least max( 1, n ), otherwise LDA must
135 *> be at least max( 1, k ).
136 *> Unchanged on exit.
137 *> \endverbatim
138 *>
139 *> \param[in] BETA
140 *> \verbatim
141 *> BETA is REAL
142 *> On entry, BETA specifies the scalar beta.
143 *> Unchanged on exit.
144 *> \endverbatim
145 *>
146 *> \param[in,out] C
147 *> \verbatim
148 *> C is COMPLEX array, dimension (N*(N+1)/2)
149 *> On entry, the matrix A in RFP Format. RFP Format is
150 *> described by TRANSR, UPLO and N. Note that the imaginary
151 *> parts of the diagonal elements need not be set, they are
152 *> assumed to be zero, and on exit they are set to zero.
153 *> \endverbatim
154 *
155 * Authors:
156 * ========
157 *
158 *> \author Univ. of Tennessee
159 *> \author Univ. of California Berkeley
160 *> \author Univ. of Colorado Denver
161 *> \author NAG Ltd.
162 *
163 *> \date September 2012
164 *
165 *> \ingroup complexOTHERcomputational
166 *
167 * =====================================================================
168  SUBROUTINE chfrk( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
169  $ c )
170 *
171 * -- LAPACK computational routine (version 3.4.2) --
172 * -- LAPACK is a software package provided by Univ. of Tennessee, --
173 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
174 * September 2012
175 *
176 * .. Scalar Arguments ..
177  REAL ALPHA, BETA
178  INTEGER K, LDA, N
179  CHARACTER TRANS, TRANSR, UPLO
180 * ..
181 * .. Array Arguments ..
182  COMPLEX A( lda, * ), C( * )
183 * ..
184 *
185 * =====================================================================
186 *
187 * ..
188 * .. Parameters ..
189  REAL ONE, ZERO
190  COMPLEX CZERO
191  parameter ( one = 1.0e+0, zero = 0.0e+0 )
192  parameter ( czero = ( 0.0e+0, 0.0e+0 ) )
193 * ..
194 * .. Local Scalars ..
195  LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
196  INTEGER INFO, NROWA, J, NK, N1, N2
197  COMPLEX CALPHA, CBETA
198 * ..
199 * .. External Functions ..
200  LOGICAL LSAME
201  EXTERNAL lsame
202 * ..
203 * .. External Subroutines ..
204  EXTERNAL cgemm, cherk, xerbla
205 * ..
206 * .. Intrinsic Functions ..
207  INTRINSIC max, cmplx
208 * ..
209 * .. Executable Statements ..
210 *
211 *
212 * Test the input parameters.
213 *
214  info = 0
215  normaltransr = lsame( transr, 'N' )
216  lower = lsame( uplo, 'L' )
217  notrans = lsame( trans, 'N' )
218 *
219  IF( notrans ) THEN
220  nrowa = n
221  ELSE
222  nrowa = k
223  END IF
224 *
225  IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
226  info = -1
227  ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
228  info = -2
229  ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'C' ) ) THEN
230  info = -3
231  ELSE IF( n.LT.0 ) THEN
232  info = -4
233  ELSE IF( k.LT.0 ) THEN
234  info = -5
235  ELSE IF( lda.LT.max( 1, nrowa ) ) THEN
236  info = -8
237  END IF
238  IF( info.NE.0 ) THEN
239  CALL xerbla( 'CHFRK ', -info )
240  RETURN
241  END IF
242 *
243 * Quick return if possible.
244 *
245 * The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not
246 * done (it is in CHERK for example) and left in the general case.
247 *
248  IF( ( n.EQ.0 ) .OR. ( ( ( alpha.EQ.zero ) .OR. ( k.EQ.0 ) ) .AND.
249  $ ( beta.EQ.one ) ) )RETURN
250 *
251  IF( ( alpha.EQ.zero ) .AND. ( beta.EQ.zero ) ) THEN
252  DO j = 1, ( ( n*( n+1 ) ) / 2 )
253  c( j ) = czero
254  END DO
255  RETURN
256  END IF
257 *
258  calpha = cmplx( alpha, zero )
259  cbeta = cmplx( beta, zero )
260 *
261 * C is N-by-N.
262 * If N is odd, set NISODD = .TRUE., and N1 and N2.
263 * If N is even, NISODD = .FALSE., and NK.
264 *
265  IF( mod( n, 2 ).EQ.0 ) THEN
266  nisodd = .false.
267  nk = n / 2
268  ELSE
269  nisodd = .true.
270  IF( lower ) THEN
271  n2 = n / 2
272  n1 = n - n2
273  ELSE
274  n1 = n / 2
275  n2 = n - n1
276  END IF
277  END IF
278 *
279  IF( nisodd ) THEN
280 *
281 * N is odd
282 *
283  IF( normaltransr ) THEN
284 *
285 * N is odd and TRANSR = 'N'
286 *
287  IF( lower ) THEN
288 *
289 * N is odd, TRANSR = 'N', and UPLO = 'L'
290 *
291  IF( notrans ) THEN
292 *
293 * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
294 *
295  CALL cherk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
296  $ beta, c( 1 ), n )
297  CALL cherk( 'U', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
298  $ beta, c( n+1 ), n )
299  CALL cgemm( 'N', 'C', n2, n1, k, calpha, a( n1+1, 1 ),
300  $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
301 *
302  ELSE
303 *
304 * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
305 *
306  CALL cherk( 'L', 'C', n1, k, alpha, a( 1, 1 ), lda,
307  $ beta, c( 1 ), n )
308  CALL cherk( 'U', 'C', n2, k, alpha, a( 1, n1+1 ), lda,
309  $ beta, c( n+1 ), n )
310  CALL cgemm( 'C', 'N', n2, n1, k, calpha, a( 1, n1+1 ),
311  $ lda, a( 1, 1 ), lda, cbeta, c( n1+1 ), n )
312 *
313  END IF
314 *
315  ELSE
316 *
317 * N is odd, TRANSR = 'N', and UPLO = 'U'
318 *
319  IF( notrans ) THEN
320 *
321 * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
322 *
323  CALL cherk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,
324  $ beta, c( n2+1 ), n )
325  CALL cherk( 'U', 'N', n2, k, alpha, a( n2, 1 ), lda,
326  $ beta, c( n1+1 ), n )
327  CALL cgemm( 'N', 'C', n1, n2, k, calpha, a( 1, 1 ),
328  $ lda, a( n2, 1 ), lda, cbeta, c( 1 ), n )
329 *
330  ELSE
331 *
332 * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
333 *
334  CALL cherk( 'L', 'C', n1, k, alpha, a( 1, 1 ), lda,
335  $ beta, c( n2+1 ), n )
336  CALL cherk( 'U', 'C', n2, k, alpha, a( 1, n2 ), lda,
337  $ beta, c( n1+1 ), n )
338  CALL cgemm( 'C', 'N', n1, n2, k, calpha, a( 1, 1 ),
339  $ lda, a( 1, n2 ), lda, cbeta, c( 1 ), n )
340 *
341  END IF
342 *
343  END IF
344 *
345  ELSE
346 *
347 * N is odd, and TRANSR = 'C'
348 *
349  IF( lower ) THEN
350 *
351 * N is odd, TRANSR = 'C', and UPLO = 'L'
352 *
353  IF( notrans ) THEN
354 *
355 * N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
356 *
357  CALL cherk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
358  $ beta, c( 1 ), n1 )
359  CALL cherk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
360  $ beta, c( 2 ), n1 )
361  CALL cgemm( 'N', 'C', n1, n2, k, calpha, a( 1, 1 ),
362  $ lda, a( n1+1, 1 ), lda, cbeta,
363  $ c( n1*n1+1 ), n1 )
364 *
365  ELSE
366 *
367 * N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
368 *
369  CALL cherk( 'U', 'C', n1, k, alpha, a( 1, 1 ), lda,
370  $ beta, c( 1 ), n1 )
371  CALL cherk( 'L', 'C', n2, k, alpha, a( 1, n1+1 ), lda,
372  $ beta, c( 2 ), n1 )
373  CALL cgemm( 'C', 'N', n1, n2, k, calpha, a( 1, 1 ),
374  $ lda, a( 1, n1+1 ), lda, cbeta,
375  $ c( n1*n1+1 ), n1 )
376 *
377  END IF
378 *
379  ELSE
380 *
381 * N is odd, TRANSR = 'C', and UPLO = 'U'
382 *
383  IF( notrans ) THEN
384 *
385 * N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
386 *
387  CALL cherk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,
388  $ beta, c( n2*n2+1 ), n2 )
389  CALL cherk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,
390  $ beta, c( n1*n2+1 ), n2 )
391  CALL cgemm( 'N', 'C', n2, n1, k, calpha, a( n1+1, 1 ),
392  $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
393 *
394  ELSE
395 *
396 * N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
397 *
398  CALL cherk( 'U', 'C', n1, k, alpha, a( 1, 1 ), lda,
399  $ beta, c( n2*n2+1 ), n2 )
400  CALL cherk( 'L', 'C', n2, k, alpha, a( 1, n1+1 ), lda,
401  $ beta, c( n1*n2+1 ), n2 )
402  CALL cgemm( 'C', 'N', n2, n1, k, calpha, a( 1, n1+1 ),
403  $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), n2 )
404 *
405  END IF
406 *
407  END IF
408 *
409  END IF
410 *
411  ELSE
412 *
413 * N is even
414 *
415  IF( normaltransr ) THEN
416 *
417 * N is even and TRANSR = 'N'
418 *
419  IF( lower ) THEN
420 *
421 * N is even, TRANSR = 'N', and UPLO = 'L'
422 *
423  IF( notrans ) THEN
424 *
425 * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
426 *
427  CALL cherk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,
428  $ beta, c( 2 ), n+1 )
429  CALL cherk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
430  $ beta, c( 1 ), n+1 )
431  CALL cgemm( 'N', 'C', nk, nk, k, calpha, a( nk+1, 1 ),
432  $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
433  $ n+1 )
434 *
435  ELSE
436 *
437 * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
438 *
439  CALL cherk( 'L', 'C', nk, k, alpha, a( 1, 1 ), lda,
440  $ beta, c( 2 ), n+1 )
441  CALL cherk( 'U', 'C', nk, k, alpha, a( 1, nk+1 ), lda,
442  $ beta, c( 1 ), n+1 )
443  CALL cgemm( 'C', 'N', nk, nk, k, calpha, a( 1, nk+1 ),
444  $ lda, a( 1, 1 ), lda, cbeta, c( nk+2 ),
445  $ n+1 )
446 *
447  END IF
448 *
449  ELSE
450 *
451 * N is even, TRANSR = 'N', and UPLO = 'U'
452 *
453  IF( notrans ) THEN
454 *
455 * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
456 *
457  CALL cherk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,
458  $ beta, c( nk+2 ), n+1 )
459  CALL cherk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
460  $ beta, c( nk+1 ), n+1 )
461  CALL cgemm( 'N', 'C', nk, nk, k, calpha, a( 1, 1 ),
462  $ lda, a( nk+1, 1 ), lda, cbeta, c( 1 ),
463  $ n+1 )
464 *
465  ELSE
466 *
467 * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
468 *
469  CALL cherk( 'L', 'C', nk, k, alpha, a( 1, 1 ), lda,
470  $ beta, c( nk+2 ), n+1 )
471  CALL cherk( 'U', 'C', nk, k, alpha, a( 1, nk+1 ), lda,
472  $ beta, c( nk+1 ), n+1 )
473  CALL cgemm( 'C', 'N', nk, nk, k, calpha, a( 1, 1 ),
474  $ lda, a( 1, nk+1 ), lda, cbeta, c( 1 ),
475  $ n+1 )
476 *
477  END IF
478 *
479  END IF
480 *
481  ELSE
482 *
483 * N is even, and TRANSR = 'C'
484 *
485  IF( lower ) THEN
486 *
487 * N is even, TRANSR = 'C', and UPLO = 'L'
488 *
489  IF( notrans ) THEN
490 *
491 * N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
492 *
493  CALL cherk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,
494  $ beta, c( nk+1 ), nk )
495  CALL cherk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
496  $ beta, c( 1 ), nk )
497  CALL cgemm( 'N', 'C', nk, nk, k, calpha, a( 1, 1 ),
498  $ lda, a( nk+1, 1 ), lda, cbeta,
499  $ c( ( ( nk+1 )*nk )+1 ), nk )
500 *
501  ELSE
502 *
503 * N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
504 *
505  CALL cherk( 'U', 'C', nk, k, alpha, a( 1, 1 ), lda,
506  $ beta, c( nk+1 ), nk )
507  CALL cherk( 'L', 'C', nk, k, alpha, a( 1, nk+1 ), lda,
508  $ beta, c( 1 ), nk )
509  CALL cgemm( 'C', 'N', nk, nk, k, calpha, a( 1, 1 ),
510  $ lda, a( 1, nk+1 ), lda, cbeta,
511  $ c( ( ( nk+1 )*nk )+1 ), nk )
512 *
513  END IF
514 *
515  ELSE
516 *
517 * N is even, TRANSR = 'C', and UPLO = 'U'
518 *
519  IF( notrans ) THEN
520 *
521 * N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
522 *
523  CALL cherk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,
524  $ beta, c( nk*( nk+1 )+1 ), nk )
525  CALL cherk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,
526  $ beta, c( nk*nk+1 ), nk )
527  CALL cgemm( 'N', 'C', nk, nk, k, calpha, a( nk+1, 1 ),
528  $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
529 *
530  ELSE
531 *
532 * N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
533 *
534  CALL cherk( 'U', 'C', nk, k, alpha, a( 1, 1 ), lda,
535  $ beta, c( nk*( nk+1 )+1 ), nk )
536  CALL cherk( 'L', 'C', nk, k, alpha, a( 1, nk+1 ), lda,
537  $ beta, c( nk*nk+1 ), nk )
538  CALL cgemm( 'C', 'N', nk, nk, k, calpha, a( 1, nk+1 ),
539  $ lda, a( 1, 1 ), lda, cbeta, c( 1 ), nk )
540 *
541  END IF
542 *
543  END IF
544 *
545  END IF
546 *
547  END IF
548 *
549  RETURN
550 *
551 * End of CHFRK
552 *
553  END
cherk
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
Definition: cherk.f:175
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
chfrk
subroutine chfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
Definition: chfrk.f:170
cgemm
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
Definition: cgemm.f:189