1: SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
2: + C )
3: *
4: * -- LAPACK routine (version 3.2.2) --
5: *
6: * -- Contributed by Julien Langou of the Univ. of Colorado Denver --
7: * -- June 2010 --
8: *
9: * -- LAPACK is a software package provided by Univ. of Tennessee, --
10: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
11: *
12: * ..
13: * .. Scalar Arguments ..
14: DOUBLE PRECISION ALPHA, BETA
15: INTEGER K, LDA, N
16: CHARACTER TRANS, TRANSR, UPLO
17: * ..
18: * .. Array Arguments ..
19: COMPLEX*16 A( LDA, * ), C( * )
20: * ..
21: *
22: * Purpose
23: * =======
24: *
25: * Level 3 BLAS like routine for C in RFP Format.
26: *
27: * ZHFRK performs one of the Hermitian rank--k operations
28: *
29: * C := alpha*A*conjg( A' ) + beta*C,
30: *
31: * or
32: *
33: * C := alpha*conjg( A' )*A + beta*C,
34: *
35: * where alpha and beta are real scalars, C is an n--by--n Hermitian
36: * matrix and A is an n--by--k matrix in the first case and a k--by--n
37: * matrix in the second case.
38: *
39: * Arguments
40: * ==========
41: *
42: * TRANSR (input) CHARACTER
43: * = 'N': The Normal Form of RFP A is stored;
44: * = 'C': The Conjugate-transpose Form of RFP A is stored.
45: *
46: * UPLO (input) CHARACTER
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: *
57: * Unchanged on exit.
58: *
59: * TRANS (input) CHARACTER
60: * On entry, TRANS specifies the operation to be performed as
61: * follows:
62: *
63: * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.
64: *
65: * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.
66: *
67: * Unchanged on exit.
68: *
69: * N (input) INTEGER
70: * On entry, N specifies the order of the matrix C. N must be
71: * at least zero.
72: * Unchanged on exit.
73: *
74: * K (input) INTEGER
75: * On entry with TRANS = 'N' or 'n', K specifies the number
76: * of columns of the matrix A, and on entry with
77: * TRANS = 'C' or 'c', K specifies the number of rows of the
78: * matrix A. K must be at least zero.
79: * Unchanged on exit.
80: *
81: * ALPHA (input) DOUBLE PRECISION
82: * On entry, ALPHA specifies the scalar alpha.
83: * Unchanged on exit.
84: *
85: * A (input) COMPLEX*16 array of DIMENSION (LDA,ka)
86: * where KA
87: * is K when TRANS = 'N' or 'n', and is N otherwise. Before
88: * entry with TRANS = 'N' or 'n', the leading N--by--K part of
89: * the array A must contain the matrix A, otherwise the leading
90: * K--by--N part of the array A must contain the matrix A.
91: * Unchanged on exit.
92: *
93: * LDA (input) INTEGER
94: * On entry, LDA specifies the first dimension of A as declared
95: * in the calling (sub) program. When TRANS = 'N' or 'n'
96: * then LDA must be at least max( 1, n ), otherwise LDA must
97: * be at least max( 1, k ).
98: * Unchanged on exit.
99: *
100: * BETA (input) DOUBLE PRECISION
101: * On entry, BETA specifies the scalar beta.
102: * Unchanged on exit.
103: *
104: * C (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
105: * On entry, the matrix A in RFP Format. RFP Format is
106: * described by TRANSR, UPLO and N. Note that the imaginary
107: * parts of the diagonal elements need not be set, they are
108: * assumed to be zero, and on exit they are set to zero.
109: *
110: * Arguments
111: * ==========
112: *
113: * ..
114: * .. Parameters ..
115: DOUBLE PRECISION ONE, ZERO
116: COMPLEX*16 CZERO
117: PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
118: PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
119: * ..
120: * .. Local Scalars ..
121: LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS
122: INTEGER INFO, NROWA, J, NK, N1, N2
123: COMPLEX*16 CALPHA, CBETA
124: * ..
125: * .. External Functions ..
126: LOGICAL LSAME
127: EXTERNAL LSAME
128: * ..
129: * .. External Subroutines ..
130: EXTERNAL XERBLA, ZGEMM, ZHERK
131: * ..
132: * .. Intrinsic Functions ..
133: INTRINSIC MAX, DCMPLX
134: * ..
135: * .. Executable Statements ..
136: *
137: *
138: * Test the input parameters.
139: *
140: INFO = 0
141: NORMALTRANSR = LSAME( TRANSR, 'N' )
142: LOWER = LSAME( UPLO, 'L' )
143: NOTRANS = LSAME( TRANS, 'N' )
144: *
145: IF( NOTRANS ) THEN
146: NROWA = N
147: ELSE
148: NROWA = K
149: END IF
150: *
151: IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN
152: INFO = -1
153: ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN
154: INFO = -2
155: ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
156: INFO = -3
157: ELSE IF( N.LT.0 ) THEN
158: INFO = -4
159: ELSE IF( K.LT.0 ) THEN
160: INFO = -5
161: ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN
162: INFO = -8
163: END IF
164: IF( INFO.NE.0 ) THEN
165: CALL XERBLA( 'ZHFRK ', -INFO )
166: RETURN
167: END IF
168: *
169: * Quick return if possible.
170: *
171: * The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not
172: * done (it is in ZHERK for example) and left in the general case.
173: *
174: IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND.
175: + ( BETA.EQ.ONE ) ) )RETURN
176: *
177: IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN
178: DO J = 1, ( ( N*( N+1 ) ) / 2 )
179: C( J ) = CZERO
180: END DO
181: RETURN
182: END IF
183: *
184: CALPHA = DCMPLX( ALPHA, ZERO )
185: CBETA = DCMPLX( BETA, ZERO )
186: *
187: * C is N-by-N.
188: * If N is odd, set NISODD = .TRUE., and N1 and N2.
189: * If N is even, NISODD = .FALSE., and NK.
190: *
191: IF( MOD( N, 2 ).EQ.0 ) THEN
192: NISODD = .FALSE.
193: NK = N / 2
194: ELSE
195: NISODD = .TRUE.
196: IF( LOWER ) THEN
197: N2 = N / 2
198: N1 = N - N2
199: ELSE
200: N1 = N / 2
201: N2 = N - N1
202: END IF
203: END IF
204: *
205: IF( NISODD ) THEN
206: *
207: * N is odd
208: *
209: IF( NORMALTRANSR ) THEN
210: *
211: * N is odd and TRANSR = 'N'
212: *
213: IF( LOWER ) THEN
214: *
215: * N is odd, TRANSR = 'N', and UPLO = 'L'
216: *
217: IF( NOTRANS ) THEN
218: *
219: * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
220: *
221: CALL ZHERK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA,
222: + BETA, C( 1 ), N )
223: CALL ZHERK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA,
224: + BETA, C( N+1 ), N )
225: CALL ZGEMM( 'N', 'C', N2, N1, K, CALPHA, A( N1+1, 1 ),
226: + LDA, A( 1, 1 ), LDA, CBETA, C( N1+1 ), N )
227: *
228: ELSE
229: *
230: * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
231: *
232: CALL ZHERK( 'L', 'C', N1, K, ALPHA, A( 1, 1 ), LDA,
233: + BETA, C( 1 ), N )
234: CALL ZHERK( 'U', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA,
235: + BETA, C( N+1 ), N )
236: CALL ZGEMM( 'C', 'N', N2, N1, K, CALPHA, A( 1, N1+1 ),
237: + LDA, A( 1, 1 ), LDA, CBETA, C( N1+1 ), N )
238: *
239: END IF
240: *
241: ELSE
242: *
243: * N is odd, TRANSR = 'N', and UPLO = 'U'
244: *
245: IF( NOTRANS ) THEN
246: *
247: * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
248: *
249: CALL ZHERK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA,
250: + BETA, C( N2+1 ), N )
251: CALL ZHERK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA,
252: + BETA, C( N1+1 ), N )
253: CALL ZGEMM( 'N', 'C', N1, N2, K, CALPHA, A( 1, 1 ),
254: + LDA, A( N2, 1 ), LDA, CBETA, C( 1 ), N )
255: *
256: ELSE
257: *
258: * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
259: *
260: CALL ZHERK( 'L', 'C', N1, K, ALPHA, A( 1, 1 ), LDA,
261: + BETA, C( N2+1 ), N )
262: CALL ZHERK( 'U', 'C', N2, K, ALPHA, A( 1, N2 ), LDA,
263: + BETA, C( N1+1 ), N )
264: CALL ZGEMM( 'C', 'N', N1, N2, K, CALPHA, A( 1, 1 ),
265: + LDA, A( 1, N2 ), LDA, CBETA, C( 1 ), N )
266: *
267: END IF
268: *
269: END IF
270: *
271: ELSE
272: *
273: * N is odd, and TRANSR = 'C'
274: *
275: IF( LOWER ) THEN
276: *
277: * N is odd, TRANSR = 'C', and UPLO = 'L'
278: *
279: IF( NOTRANS ) THEN
280: *
281: * N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
282: *
283: CALL ZHERK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA,
284: + BETA, C( 1 ), N1 )
285: CALL ZHERK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA,
286: + BETA, C( 2 ), N1 )
287: CALL ZGEMM( 'N', 'C', N1, N2, K, CALPHA, A( 1, 1 ),
288: + LDA, A( N1+1, 1 ), LDA, CBETA,
289: + C( N1*N1+1 ), N1 )
290: *
291: ELSE
292: *
293: * N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
294: *
295: CALL ZHERK( 'U', 'C', N1, K, ALPHA, A( 1, 1 ), LDA,
296: + BETA, C( 1 ), N1 )
297: CALL ZHERK( 'L', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA,
298: + BETA, C( 2 ), N1 )
299: CALL ZGEMM( 'C', 'N', N1, N2, K, CALPHA, A( 1, 1 ),
300: + LDA, A( 1, N1+1 ), LDA, CBETA,
301: + C( N1*N1+1 ), N1 )
302: *
303: END IF
304: *
305: ELSE
306: *
307: * N is odd, TRANSR = 'C', and UPLO = 'U'
308: *
309: IF( NOTRANS ) THEN
310: *
311: * N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
312: *
313: CALL ZHERK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA,
314: + BETA, C( N2*N2+1 ), N2 )
315: CALL ZHERK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA,
316: + BETA, C( N1*N2+1 ), N2 )
317: CALL ZGEMM( 'N', 'C', N2, N1, K, CALPHA, A( N1+1, 1 ),
318: + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), N2 )
319: *
320: ELSE
321: *
322: * N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
323: *
324: CALL ZHERK( 'U', 'C', N1, K, ALPHA, A( 1, 1 ), LDA,
325: + BETA, C( N2*N2+1 ), N2 )
326: CALL ZHERK( 'L', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA,
327: + BETA, C( N1*N2+1 ), N2 )
328: CALL ZGEMM( 'C', 'N', N2, N1, K, CALPHA, A( 1, N1+1 ),
329: + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), N2 )
330: *
331: END IF
332: *
333: END IF
334: *
335: END IF
336: *
337: ELSE
338: *
339: * N is even
340: *
341: IF( NORMALTRANSR ) THEN
342: *
343: * N is even and TRANSR = 'N'
344: *
345: IF( LOWER ) THEN
346: *
347: * N is even, TRANSR = 'N', and UPLO = 'L'
348: *
349: IF( NOTRANS ) THEN
350: *
351: * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N'
352: *
353: CALL ZHERK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA,
354: + BETA, C( 2 ), N+1 )
355: CALL ZHERK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA,
356: + BETA, C( 1 ), N+1 )
357: CALL ZGEMM( 'N', 'C', NK, NK, K, CALPHA, A( NK+1, 1 ),
358: + LDA, A( 1, 1 ), LDA, CBETA, C( NK+2 ),
359: + N+1 )
360: *
361: ELSE
362: *
363: * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C'
364: *
365: CALL ZHERK( 'L', 'C', NK, K, ALPHA, A( 1, 1 ), LDA,
366: + BETA, C( 2 ), N+1 )
367: CALL ZHERK( 'U', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA,
368: + BETA, C( 1 ), N+1 )
369: CALL ZGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, NK+1 ),
370: + LDA, A( 1, 1 ), LDA, CBETA, C( NK+2 ),
371: + N+1 )
372: *
373: END IF
374: *
375: ELSE
376: *
377: * N is even, TRANSR = 'N', and UPLO = 'U'
378: *
379: IF( NOTRANS ) THEN
380: *
381: * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N'
382: *
383: CALL ZHERK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA,
384: + BETA, C( NK+2 ), N+1 )
385: CALL ZHERK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA,
386: + BETA, C( NK+1 ), N+1 )
387: CALL ZGEMM( 'N', 'C', NK, NK, K, CALPHA, A( 1, 1 ),
388: + LDA, A( NK+1, 1 ), LDA, CBETA, C( 1 ),
389: + N+1 )
390: *
391: ELSE
392: *
393: * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C'
394: *
395: CALL ZHERK( 'L', 'C', NK, K, ALPHA, A( 1, 1 ), LDA,
396: + BETA, C( NK+2 ), N+1 )
397: CALL ZHERK( 'U', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA,
398: + BETA, C( NK+1 ), N+1 )
399: CALL ZGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, 1 ),
400: + LDA, A( 1, NK+1 ), LDA, CBETA, C( 1 ),
401: + N+1 )
402: *
403: END IF
404: *
405: END IF
406: *
407: ELSE
408: *
409: * N is even, and TRANSR = 'C'
410: *
411: IF( LOWER ) THEN
412: *
413: * N is even, TRANSR = 'C', and UPLO = 'L'
414: *
415: IF( NOTRANS ) THEN
416: *
417: * N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N'
418: *
419: CALL ZHERK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA,
420: + BETA, C( NK+1 ), NK )
421: CALL ZHERK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA,
422: + BETA, C( 1 ), NK )
423: CALL ZGEMM( 'N', 'C', NK, NK, K, CALPHA, A( 1, 1 ),
424: + LDA, A( NK+1, 1 ), LDA, CBETA,
425: + C( ( ( NK+1 )*NK )+1 ), NK )
426: *
427: ELSE
428: *
429: * N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C'
430: *
431: CALL ZHERK( 'U', 'C', NK, K, ALPHA, A( 1, 1 ), LDA,
432: + BETA, C( NK+1 ), NK )
433: CALL ZHERK( 'L', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA,
434: + BETA, C( 1 ), NK )
435: CALL ZGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, 1 ),
436: + LDA, A( 1, NK+1 ), LDA, CBETA,
437: + C( ( ( NK+1 )*NK )+1 ), NK )
438: *
439: END IF
440: *
441: ELSE
442: *
443: * N is even, TRANSR = 'C', and UPLO = 'U'
444: *
445: IF( NOTRANS ) THEN
446: *
447: * N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N'
448: *
449: CALL ZHERK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA,
450: + BETA, C( NK*( NK+1 )+1 ), NK )
451: CALL ZHERK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA,
452: + BETA, C( NK*NK+1 ), NK )
453: CALL ZGEMM( 'N', 'C', NK, NK, K, CALPHA, A( NK+1, 1 ),
454: + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), NK )
455: *
456: ELSE
457: *
458: * N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C'
459: *
460: CALL ZHERK( 'U', 'C', NK, K, ALPHA, A( 1, 1 ), LDA,
461: + BETA, C( NK*( NK+1 )+1 ), NK )
462: CALL ZHERK( 'L', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA,
463: + BETA, C( NK*NK+1 ), NK )
464: CALL ZGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, NK+1 ),
465: + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), NK )
466: *
467: END IF
468: *
469: END IF
470: *
471: END IF
472: *
473: END IF
474: *
475: RETURN
476: *
477: * End of ZHFRK
478: *
479: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zhfrk.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack