LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
ztfsm.f
Go to the documentation of this file.
1*> \brief \b ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> Download ZTFSM + dependencies
9*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ztfsm.f">
10*> [TGZ]</a>
11*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ztfsm.f">
12*> [ZIP]</a>
13*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ztfsm.f">
14*> [TXT]</a>
15*
16* Definition:
17* ===========
18*
19* SUBROUTINE ZTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A,
20* B, LDB )
21*
22* .. Scalar Arguments ..
23* CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO
24* INTEGER LDB, M, N
25* COMPLEX*16 ALPHA
26* ..
27* .. Array Arguments ..
28* COMPLEX*16 A( 0: * ), B( 0: LDB-1, 0: * )
29* ..
30*
31*
32*> \par Purpose:
33* =============
34*>
35*> \verbatim
36*>
37*> Level 3 BLAS like routine for A in RFP Format.
38*>
39*> ZTFSM solves the matrix equation
40*>
41*> op( A )*X = alpha*B or X*op( A ) = alpha*B
42*>
43*> where alpha is a scalar, X and B are m by n matrices, A is a unit, or
44*> non-unit, upper or lower triangular matrix and op( A ) is one of
45*>
46*> op( A ) = A or op( A ) = A**H.
47*>
48*> A is in Rectangular Full Packed (RFP) Format.
49*>
50*> The matrix X is overwritten on B.
51*> \endverbatim
52*
53* Arguments:
54* ==========
55*
56*> \param[in] TRANSR
57*> \verbatim
58*> TRANSR is CHARACTER*1
59*> = 'N': The Normal Form of RFP A is stored;
60*> = 'C': The Conjugate-transpose Form of RFP A is stored.
61*> \endverbatim
62*>
63*> \param[in] SIDE
64*> \verbatim
65*> SIDE is CHARACTER*1
66*> On entry, SIDE specifies whether op( A ) appears on the left
67*> or right of X as follows:
68*>
69*> SIDE = 'L' or 'l' op( A )*X = alpha*B.
70*>
71*> SIDE = 'R' or 'r' X*op( A ) = alpha*B.
72*>
73*> Unchanged on exit.
74*> \endverbatim
75*>
76*> \param[in] UPLO
77*> \verbatim
78*> UPLO is CHARACTER*1
79*> On entry, UPLO specifies whether the RFP matrix A came from
80*> an upper or lower triangular matrix as follows:
81*> UPLO = 'U' or 'u' RFP A came from an upper triangular matrix
82*> UPLO = 'L' or 'l' RFP A came from a lower triangular matrix
83*>
84*> Unchanged on exit.
85*> \endverbatim
86*>
87*> \param[in] TRANS
88*> \verbatim
89*> TRANS is CHARACTER*1
90*> On entry, TRANS specifies the form of op( A ) to be used
91*> in the matrix multiplication as follows:
92*>
93*> TRANS = 'N' or 'n' op( A ) = A.
94*>
95*> TRANS = 'C' or 'c' op( A ) = conjg( A' ).
96*>
97*> Unchanged on exit.
98*> \endverbatim
99*>
100*> \param[in] DIAG
101*> \verbatim
102*> DIAG is CHARACTER*1
103*> On entry, DIAG specifies whether or not RFP A is unit
104*> triangular as follows:
105*>
106*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
107*>
108*> DIAG = 'N' or 'n' A is not assumed to be unit
109*> triangular.
110*>
111*> Unchanged on exit.
112*> \endverbatim
113*>
114*> \param[in] M
115*> \verbatim
116*> M is INTEGER
117*> On entry, M specifies the number of rows of B. M must be at
118*> least zero.
119*> Unchanged on exit.
120*> \endverbatim
121*>
122*> \param[in] N
123*> \verbatim
124*> N is INTEGER
125*> On entry, N specifies the number of columns of B. N must be
126*> at least zero.
127*> Unchanged on exit.
128*> \endverbatim
129*>
130*> \param[in] ALPHA
131*> \verbatim
132*> ALPHA is COMPLEX*16
133*> On entry, ALPHA specifies the scalar alpha. When alpha is
134*> zero then A is not referenced and B need not be set before
135*> entry.
136*> Unchanged on exit.
137*> \endverbatim
138*>
139*> \param[in] A
140*> \verbatim
141*> A is COMPLEX*16 array, dimension (N*(N+1)/2)
142*> NT = N*(N+1)/2 if SIDE='R' and NT = M*(M+1)/2 otherwise.
143*> On entry, the matrix A in RFP Format.
144*> RFP Format is described by TRANSR, UPLO and N as follows:
145*> If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;
146*> K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If
147*> TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as
148*> defined when TRANSR = 'N'. The contents of RFP A are defined
149*> by UPLO as follows: If UPLO = 'U' the RFP A contains the NT
150*> elements of upper packed A either in normal or
151*> conjugate-transpose Format. If UPLO = 'L' the RFP A contains
152*> the NT elements of lower packed A either in normal or
153*> conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when
154*> TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is
155*> even and is N when is odd.
156*> See the Note below for more details. Unchanged on exit.
157*> \endverbatim
158*>
159*> \param[in,out] B
160*> \verbatim
161*> B is COMPLEX*16 array, dimension (LDB,N)
162*> Before entry, the leading m by n part of the array B must
163*> contain the right-hand side matrix B, and on exit is
164*> overwritten by the solution matrix X.
165*> \endverbatim
166*>
167*> \param[in] LDB
168*> \verbatim
169*> LDB is INTEGER
170*> On entry, LDB specifies the first dimension of B as declared
171*> in the calling (sub) program. LDB must be at least
172*> max( 1, m ).
173*> Unchanged on exit.
174*> \endverbatim
175*
176* Authors:
177* ========
178*
179*> \author Univ. of Tennessee
180*> \author Univ. of California Berkeley
181*> \author Univ. of Colorado Denver
182*> \author NAG Ltd.
183*
184*> \ingroup tfsm
185*
186*> \par Further Details:
187* =====================
188*>
189*> \verbatim
190*>
191*> We first consider Standard Packed Format when N is even.
192*> We give an example where N = 6.
193*>
194*> AP is Upper AP is Lower
195*>
196*> 00 01 02 03 04 05 00
197*> 11 12 13 14 15 10 11
198*> 22 23 24 25 20 21 22
199*> 33 34 35 30 31 32 33
200*> 44 45 40 41 42 43 44
201*> 55 50 51 52 53 54 55
202*>
203*>
204*> Let TRANSR = 'N'. RFP holds AP as follows:
205*> For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
206*> three columns of AP upper. The lower triangle A(4:6,0:2) consists of
207*> conjugate-transpose of the first three columns of AP upper.
208*> For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
209*> three columns of AP lower. The upper triangle A(0:2,0:2) consists of
210*> conjugate-transpose of the last three columns of AP lower.
211*> To denote conjugate we place -- above the element. This covers the
212*> case N even and TRANSR = 'N'.
213*>
214*> RFP A RFP A
215*>
216*> -- -- --
217*> 03 04 05 33 43 53
218*> -- --
219*> 13 14 15 00 44 54
220*> --
221*> 23 24 25 10 11 55
222*>
223*> 33 34 35 20 21 22
224*> --
225*> 00 44 45 30 31 32
226*> -- --
227*> 01 11 55 40 41 42
228*> -- -- --
229*> 02 12 22 50 51 52
230*>
231*> Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
232*> transpose of RFP A above. One therefore gets:
233*>
234*>
235*> RFP A RFP A
236*>
237*> -- -- -- -- -- -- -- -- -- --
238*> 03 13 23 33 00 01 02 33 00 10 20 30 40 50
239*> -- -- -- -- -- -- -- -- -- --
240*> 04 14 24 34 44 11 12 43 44 11 21 31 41 51
241*> -- -- -- -- -- -- -- -- -- --
242*> 05 15 25 35 45 55 22 53 54 55 22 32 42 52
243*>
244*>
245*> We next consider Standard Packed Format when N is odd.
246*> We give an example where N = 5.
247*>
248*> AP is Upper AP is Lower
249*>
250*> 00 01 02 03 04 00
251*> 11 12 13 14 10 11
252*> 22 23 24 20 21 22
253*> 33 34 30 31 32 33
254*> 44 40 41 42 43 44
255*>
256*>
257*> Let TRANSR = 'N'. RFP holds AP as follows:
258*> For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
259*> three columns of AP upper. The lower triangle A(3:4,0:1) consists of
260*> conjugate-transpose of the first two columns of AP upper.
261*> For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
262*> three columns of AP lower. The upper triangle A(0:1,1:2) consists of
263*> conjugate-transpose of the last two columns of AP lower.
264*> To denote conjugate we place -- above the element. This covers the
265*> case N odd and TRANSR = 'N'.
266*>
267*> RFP A RFP A
268*>
269*> -- --
270*> 02 03 04 00 33 43
271*> --
272*> 12 13 14 10 11 44
273*>
274*> 22 23 24 20 21 22
275*> --
276*> 00 33 34 30 31 32
277*> -- --
278*> 01 11 44 40 41 42
279*>
280*> Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
281*> transpose of RFP A above. One therefore gets:
282*>
283*>
284*> RFP A RFP A
285*>
286*> -- -- -- -- -- -- -- -- --
287*> 02 12 22 00 01 00 10 20 30 40 50
288*> -- -- -- -- -- -- -- -- --
289*> 03 13 23 33 11 33 11 21 31 41 51
290*> -- -- -- -- -- -- -- -- --
291*> 04 14 24 34 44 43 44 22 32 42 52
292*> \endverbatim
293*>
294* =====================================================================
295 SUBROUTINE ztfsm( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA,
296 $ A,
297 $ B, LDB )
298*
299* -- LAPACK computational routine --
300* -- LAPACK is a software package provided by Univ. of Tennessee, --
301* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
302*
303* .. Scalar Arguments ..
304 CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO
305 INTEGER LDB, M, N
306 COMPLEX*16 ALPHA
307* ..
308* .. Array Arguments ..
309 COMPLEX*16 A( 0: * ), B( 0: LDB-1, 0: * )
310* ..
311*
312* =====================================================================
313* ..
314* .. Parameters ..
315 COMPLEX*16 CONE, CZERO
316 PARAMETER ( CONE = ( 1.0d+0, 0.0d+0 ),
317 $ czero = ( 0.0d+0, 0.0d+0 ) )
318* ..
319* .. Local Scalars ..
320 LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR,
321 $ NOTRANS
322 INTEGER M1, M2, N1, N2, K, INFO, I, J
323* ..
324* .. External Functions ..
325 LOGICAL LSAME
326 EXTERNAL LSAME
327* ..
328* .. External Subroutines ..
329 EXTERNAL xerbla, zgemm, ztrsm
330* ..
331* .. Intrinsic Functions ..
332 INTRINSIC max, mod
333* ..
334* .. Executable Statements ..
335*
336* Test the input parameters.
337*
338 info = 0
339 normaltransr = lsame( transr, 'N' )
340 lside = lsame( side, 'L' )
341 lower = lsame( uplo, 'L' )
342 notrans = lsame( trans, 'N' )
343 IF( .NOT.normaltransr .AND. .NOT.lsame( transr, 'C' ) ) THEN
344 info = -1
345 ELSE IF( .NOT.lside .AND. .NOT.lsame( side, 'R' ) ) THEN
346 info = -2
347 ELSE IF( .NOT.lower .AND. .NOT.lsame( uplo, 'U' ) ) THEN
348 info = -3
349 ELSE IF( .NOT.notrans .AND. .NOT.lsame( trans, 'C' ) ) THEN
350 info = -4
351 ELSE IF( .NOT.lsame( diag, 'N' ) .AND.
352 $ .NOT.lsame( diag, 'U' ) )
353 $ THEN
354 info = -5
355 ELSE IF( m.LT.0 ) THEN
356 info = -6
357 ELSE IF( n.LT.0 ) THEN
358 info = -7
359 ELSE IF( ldb.LT.max( 1, m ) ) THEN
360 info = -11
361 END IF
362 IF( info.NE.0 ) THEN
363 CALL xerbla( 'ZTFSM ', -info )
364 RETURN
365 END IF
366*
367* Quick return when ( (N.EQ.0).OR.(M.EQ.0) )
368*
369 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
370 $ RETURN
371*
372* Quick return when ALPHA.EQ.(0D+0,0D+0)
373*
374 IF( alpha.EQ.czero ) THEN
375 DO 20 j = 0, n - 1
376 DO 10 i = 0, m - 1
377 b( i, j ) = czero
378 10 CONTINUE
379 20 CONTINUE
380 RETURN
381 END IF
382*
383 IF( lside ) THEN
384*
385* SIDE = 'L'
386*
387* A is M-by-M.
388* If M is odd, set NISODD = .TRUE., and M1 and M2.
389* If M is even, NISODD = .FALSE., and M.
390*
391 IF( mod( m, 2 ).EQ.0 ) THEN
392 misodd = .false.
393 k = m / 2
394 ELSE
395 misodd = .true.
396 IF( lower ) THEN
397 m2 = m / 2
398 m1 = m - m2
399 ELSE
400 m1 = m / 2
401 m2 = m - m1
402 END IF
403 END IF
404*
405 IF( misodd ) THEN
406*
407* SIDE = 'L' and N is odd
408*
409 IF( normaltransr ) THEN
410*
411* SIDE = 'L', N is odd, and TRANSR = 'N'
412*
413 IF( lower ) THEN
414*
415* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L'
416*
417 IF( notrans ) THEN
418*
419* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
420* TRANS = 'N'
421*
422 IF( m.EQ.1 ) THEN
423 CALL ztrsm( 'L', 'L', 'N', diag, m1, n,
424 $ alpha,
425 $ a, m, b, ldb )
426 ELSE
427 CALL ztrsm( 'L', 'L', 'N', diag, m1, n,
428 $ alpha,
429 $ a( 0 ), m, b, ldb )
430 CALL zgemm( 'N', 'N', m2, n, m1, -cone,
431 $ a( m1 ),
432 $ m, b, ldb, alpha, b( m1, 0 ), ldb )
433 CALL ztrsm( 'L', 'U', 'C', diag, m2, n, cone,
434 $ a( m ), m, b( m1, 0 ), ldb )
435 END IF
436*
437 ELSE
438*
439* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and
440* TRANS = 'C'
441*
442 IF( m.EQ.1 ) THEN
443 CALL ztrsm( 'L', 'L', 'C', diag, m1, n,
444 $ alpha,
445 $ a( 0 ), m, b, ldb )
446 ELSE
447 CALL ztrsm( 'L', 'U', 'N', diag, m2, n,
448 $ alpha,
449 $ a( m ), m, b( m1, 0 ), ldb )
450 CALL zgemm( 'C', 'N', m1, n, m2, -cone,
451 $ a( m1 ),
452 $ m, b( m1, 0 ), ldb, alpha, b, ldb )
453 CALL ztrsm( 'L', 'L', 'C', diag, m1, n, cone,
454 $ a( 0 ), m, b, ldb )
455 END IF
456*
457 END IF
458*
459 ELSE
460*
461* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U'
462*
463 IF( .NOT.notrans ) THEN
464*
465* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
466* TRANS = 'N'
467*
468 CALL ztrsm( 'L', 'L', 'N', diag, m1, n, alpha,
469 $ a( m2 ), m, b, ldb )
470 CALL zgemm( 'C', 'N', m2, n, m1, -cone, a( 0 ),
471 $ m,
472 $ b, ldb, alpha, b( m1, 0 ), ldb )
473 CALL ztrsm( 'L', 'U', 'C', diag, m2, n, cone,
474 $ a( m1 ), m, b( m1, 0 ), ldb )
475*
476 ELSE
477*
478* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and
479* TRANS = 'C'
480*
481 CALL ztrsm( 'L', 'U', 'N', diag, m2, n, alpha,
482 $ a( m1 ), m, b( m1, 0 ), ldb )
483 CALL zgemm( 'N', 'N', m1, n, m2, -cone, a( 0 ),
484 $ m,
485 $ b( m1, 0 ), ldb, alpha, b, ldb )
486 CALL ztrsm( 'L', 'L', 'C', diag, m1, n, cone,
487 $ a( m2 ), m, b, ldb )
488*
489 END IF
490*
491 END IF
492*
493 ELSE
494*
495* SIDE = 'L', N is odd, and TRANSR = 'C'
496*
497 IF( lower ) THEN
498*
499* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'L'
500*
501 IF( notrans ) THEN
502*
503* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and
504* TRANS = 'N'
505*
506 IF( m.EQ.1 ) THEN
507 CALL ztrsm( 'L', 'U', 'C', diag, m1, n,
508 $ alpha,
509 $ a( 0 ), m1, b, ldb )
510 ELSE
511 CALL ztrsm( 'L', 'U', 'C', diag, m1, n,
512 $ alpha,
513 $ a( 0 ), m1, b, ldb )
514 CALL zgemm( 'C', 'N', m2, n, m1, -cone,
515 $ a( m1*m1 ), m1, b, ldb, alpha,
516 $ b( m1, 0 ), ldb )
517 CALL ztrsm( 'L', 'L', 'N', diag, m2, n, cone,
518 $ a( 1 ), m1, b( m1, 0 ), ldb )
519 END IF
520*
521 ELSE
522*
523* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and
524* TRANS = 'C'
525*
526 IF( m.EQ.1 ) THEN
527 CALL ztrsm( 'L', 'U', 'N', diag, m1, n,
528 $ alpha,
529 $ a( 0 ), m1, b, ldb )
530 ELSE
531 CALL ztrsm( 'L', 'L', 'C', diag, m2, n,
532 $ alpha,
533 $ a( 1 ), m1, b( m1, 0 ), ldb )
534 CALL zgemm( 'N', 'N', m1, n, m2, -cone,
535 $ a( m1*m1 ), m1, b( m1, 0 ), ldb,
536 $ alpha, b, ldb )
537 CALL ztrsm( 'L', 'U', 'N', diag, m1, n, cone,
538 $ a( 0 ), m1, b, ldb )
539 END IF
540*
541 END IF
542*
543 ELSE
544*
545* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'U'
546*
547 IF( .NOT.notrans ) THEN
548*
549* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and
550* TRANS = 'N'
551*
552 CALL ztrsm( 'L', 'U', 'C', diag, m1, n, alpha,
553 $ a( m2*m2 ), m2, b, ldb )
554 CALL zgemm( 'N', 'N', m2, n, m1, -cone, a( 0 ),
555 $ m2,
556 $ b, ldb, alpha, b( m1, 0 ), ldb )
557 CALL ztrsm( 'L', 'L', 'N', diag, m2, n, cone,
558 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
559*
560 ELSE
561*
562* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and
563* TRANS = 'C'
564*
565 CALL ztrsm( 'L', 'L', 'C', diag, m2, n, alpha,
566 $ a( m1*m2 ), m2, b( m1, 0 ), ldb )
567 CALL zgemm( 'C', 'N', m1, n, m2, -cone, a( 0 ),
568 $ m2,
569 $ b( m1, 0 ), ldb, alpha, b, ldb )
570 CALL ztrsm( 'L', 'U', 'N', diag, m1, n, cone,
571 $ a( m2*m2 ), m2, b, ldb )
572*
573 END IF
574*
575 END IF
576*
577 END IF
578*
579 ELSE
580*
581* SIDE = 'L' and N is even
582*
583 IF( normaltransr ) THEN
584*
585* SIDE = 'L', N is even, and TRANSR = 'N'
586*
587 IF( lower ) THEN
588*
589* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L'
590*
591 IF( notrans ) THEN
592*
593* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
594* and TRANS = 'N'
595*
596 CALL ztrsm( 'L', 'L', 'N', diag, k, n, alpha,
597 $ a( 1 ), m+1, b, ldb )
598 CALL zgemm( 'N', 'N', k, n, k, -cone, a( k+1 ),
599 $ m+1, b, ldb, alpha, b( k, 0 ), ldb )
600 CALL ztrsm( 'L', 'U', 'C', diag, k, n, cone,
601 $ a( 0 ), m+1, b( k, 0 ), ldb )
602*
603 ELSE
604*
605* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L',
606* and TRANS = 'C'
607*
608 CALL ztrsm( 'L', 'U', 'N', diag, k, n, alpha,
609 $ a( 0 ), m+1, b( k, 0 ), ldb )
610 CALL zgemm( 'C', 'N', k, n, k, -cone, a( k+1 ),
611 $ m+1, b( k, 0 ), ldb, alpha, b, ldb )
612 CALL ztrsm( 'L', 'L', 'C', diag, k, n, cone,
613 $ a( 1 ), m+1, b, ldb )
614*
615 END IF
616*
617 ELSE
618*
619* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U'
620*
621 IF( .NOT.notrans ) THEN
622*
623* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
624* and TRANS = 'N'
625*
626 CALL ztrsm( 'L', 'L', 'N', diag, k, n, alpha,
627 $ a( k+1 ), m+1, b, ldb )
628 CALL zgemm( 'C', 'N', k, n, k, -cone, a( 0 ),
629 $ m+1,
630 $ b, ldb, alpha, b( k, 0 ), ldb )
631 CALL ztrsm( 'L', 'U', 'C', diag, k, n, cone,
632 $ a( k ), m+1, b( k, 0 ), ldb )
633*
634 ELSE
635*
636* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U',
637* and TRANS = 'C'
638 CALL ztrsm( 'L', 'U', 'N', diag, k, n, alpha,
639 $ a( k ), m+1, b( k, 0 ), ldb )
640 CALL zgemm( 'N', 'N', k, n, k, -cone, a( 0 ),
641 $ m+1,
642 $ b( k, 0 ), ldb, alpha, b, ldb )
643 CALL ztrsm( 'L', 'L', 'C', diag, k, n, cone,
644 $ a( k+1 ), m+1, b, ldb )
645*
646 END IF
647*
648 END IF
649*
650 ELSE
651*
652* SIDE = 'L', N is even, and TRANSR = 'C'
653*
654 IF( lower ) THEN
655*
656* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'L'
657*
658 IF( notrans ) THEN
659*
660* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L',
661* and TRANS = 'N'
662*
663 CALL ztrsm( 'L', 'U', 'C', diag, k, n, alpha,
664 $ a( k ), k, b, ldb )
665 CALL zgemm( 'C', 'N', k, n, k, -cone,
666 $ a( k*( k+1 ) ), k, b, ldb, alpha,
667 $ b( k, 0 ), ldb )
668 CALL ztrsm( 'L', 'L', 'N', diag, k, n, cone,
669 $ a( 0 ), k, b( k, 0 ), ldb )
670*
671 ELSE
672*
673* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L',
674* and TRANS = 'C'
675*
676 CALL ztrsm( 'L', 'L', 'C', diag, k, n, alpha,
677 $ a( 0 ), k, b( k, 0 ), ldb )
678 CALL zgemm( 'N', 'N', k, n, k, -cone,
679 $ a( k*( k+1 ) ), k, b( k, 0 ), ldb,
680 $ alpha, b, ldb )
681 CALL ztrsm( 'L', 'U', 'N', diag, k, n, cone,
682 $ a( k ), k, b, ldb )
683*
684 END IF
685*
686 ELSE
687*
688* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'U'
689*
690 IF( .NOT.notrans ) THEN
691*
692* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U',
693* and TRANS = 'N'
694*
695 CALL ztrsm( 'L', 'U', 'C', diag, k, n, alpha,
696 $ a( k*( k+1 ) ), k, b, ldb )
697 CALL zgemm( 'N', 'N', k, n, k, -cone, a( 0 ), k,
698 $ b,
699 $ ldb, alpha, b( k, 0 ), ldb )
700 CALL ztrsm( 'L', 'L', 'N', diag, k, n, cone,
701 $ a( k*k ), k, b( k, 0 ), ldb )
702*
703 ELSE
704*
705* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U',
706* and TRANS = 'C'
707*
708 CALL ztrsm( 'L', 'L', 'C', diag, k, n, alpha,
709 $ a( k*k ), k, b( k, 0 ), ldb )
710 CALL zgemm( 'C', 'N', k, n, k, -cone, a( 0 ), k,
711 $ b( k, 0 ), ldb, alpha, b, ldb )
712 CALL ztrsm( 'L', 'U', 'N', diag, k, n, cone,
713 $ a( k*( k+1 ) ), k, b, ldb )
714*
715 END IF
716*
717 END IF
718*
719 END IF
720*
721 END IF
722*
723 ELSE
724*
725* SIDE = 'R'
726*
727* A is N-by-N.
728* If N is odd, set NISODD = .TRUE., and N1 and N2.
729* If N is even, NISODD = .FALSE., and K.
730*
731 IF( mod( n, 2 ).EQ.0 ) THEN
732 nisodd = .false.
733 k = n / 2
734 ELSE
735 nisodd = .true.
736 IF( lower ) THEN
737 n2 = n / 2
738 n1 = n - n2
739 ELSE
740 n1 = n / 2
741 n2 = n - n1
742 END IF
743 END IF
744*
745 IF( nisodd ) THEN
746*
747* SIDE = 'R' and N is odd
748*
749 IF( normaltransr ) THEN
750*
751* SIDE = 'R', N is odd, and TRANSR = 'N'
752*
753 IF( lower ) THEN
754*
755* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L'
756*
757 IF( notrans ) THEN
758*
759* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
760* TRANS = 'N'
761*
762 CALL ztrsm( 'R', 'U', 'C', diag, m, n2, alpha,
763 $ a( n ), n, b( 0, n1 ), ldb )
764 CALL zgemm( 'N', 'N', m, n1, n2, -cone, b( 0,
765 $ n1 ),
766 $ ldb, a( n1 ), n, alpha, b( 0, 0 ),
767 $ ldb )
768 CALL ztrsm( 'R', 'L', 'N', diag, m, n1, cone,
769 $ a( 0 ), n, b( 0, 0 ), ldb )
770*
771 ELSE
772*
773* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and
774* TRANS = 'C'
775*
776 CALL ztrsm( 'R', 'L', 'C', diag, m, n1, alpha,
777 $ a( 0 ), n, b( 0, 0 ), ldb )
778 CALL zgemm( 'N', 'C', m, n2, n1, -cone, b( 0,
779 $ 0 ),
780 $ ldb, a( n1 ), n, alpha, b( 0, n1 ),
781 $ ldb )
782 CALL ztrsm( 'R', 'U', 'N', diag, m, n2, cone,
783 $ a( n ), n, b( 0, n1 ), ldb )
784*
785 END IF
786*
787 ELSE
788*
789* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U'
790*
791 IF( notrans ) THEN
792*
793* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
794* TRANS = 'N'
795*
796 CALL ztrsm( 'R', 'L', 'C', diag, m, n1, alpha,
797 $ a( n2 ), n, b( 0, 0 ), ldb )
798 CALL zgemm( 'N', 'N', m, n2, n1, -cone, b( 0,
799 $ 0 ),
800 $ ldb, a( 0 ), n, alpha, b( 0, n1 ),
801 $ ldb )
802 CALL ztrsm( 'R', 'U', 'N', diag, m, n2, cone,
803 $ a( n1 ), n, b( 0, n1 ), ldb )
804*
805 ELSE
806*
807* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and
808* TRANS = 'C'
809*
810 CALL ztrsm( 'R', 'U', 'C', diag, m, n2, alpha,
811 $ a( n1 ), n, b( 0, n1 ), ldb )
812 CALL zgemm( 'N', 'C', m, n1, n2, -cone, b( 0,
813 $ n1 ),
814 $ ldb, a( 0 ), n, alpha, b( 0, 0 ), ldb )
815 CALL ztrsm( 'R', 'L', 'N', diag, m, n1, cone,
816 $ a( n2 ), n, b( 0, 0 ), ldb )
817*
818 END IF
819*
820 END IF
821*
822 ELSE
823*
824* SIDE = 'R', N is odd, and TRANSR = 'C'
825*
826 IF( lower ) THEN
827*
828* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'L'
829*
830 IF( notrans ) THEN
831*
832* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and
833* TRANS = 'N'
834*
835 CALL ztrsm( 'R', 'L', 'N', diag, m, n2, alpha,
836 $ a( 1 ), n1, b( 0, n1 ), ldb )
837 CALL zgemm( 'N', 'C', m, n1, n2, -cone, b( 0,
838 $ n1 ),
839 $ ldb, a( n1*n1 ), n1, alpha, b( 0, 0 ),
840 $ ldb )
841 CALL ztrsm( 'R', 'U', 'C', diag, m, n1, cone,
842 $ a( 0 ), n1, b( 0, 0 ), ldb )
843*
844 ELSE
845*
846* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and
847* TRANS = 'C'
848*
849 CALL ztrsm( 'R', 'U', 'N', diag, m, n1, alpha,
850 $ a( 0 ), n1, b( 0, 0 ), ldb )
851 CALL zgemm( 'N', 'N', m, n2, n1, -cone, b( 0,
852 $ 0 ),
853 $ ldb, a( n1*n1 ), n1, alpha, b( 0, n1 ),
854 $ ldb )
855 CALL ztrsm( 'R', 'L', 'C', diag, m, n2, cone,
856 $ a( 1 ), n1, b( 0, n1 ), ldb )
857*
858 END IF
859*
860 ELSE
861*
862* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'U'
863*
864 IF( notrans ) THEN
865*
866* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and
867* TRANS = 'N'
868*
869 CALL ztrsm( 'R', 'U', 'N', diag, m, n1, alpha,
870 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
871 CALL zgemm( 'N', 'C', m, n2, n1, -cone, b( 0,
872 $ 0 ),
873 $ ldb, a( 0 ), n2, alpha, b( 0, n1 ),
874 $ ldb )
875 CALL ztrsm( 'R', 'L', 'C', diag, m, n2, cone,
876 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
877*
878 ELSE
879*
880* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and
881* TRANS = 'C'
882*
883 CALL ztrsm( 'R', 'L', 'N', diag, m, n2, alpha,
884 $ a( n1*n2 ), n2, b( 0, n1 ), ldb )
885 CALL zgemm( 'N', 'N', m, n1, n2, -cone, b( 0,
886 $ n1 ),
887 $ ldb, a( 0 ), n2, alpha, b( 0, 0 ),
888 $ ldb )
889 CALL ztrsm( 'R', 'U', 'C', diag, m, n1, cone,
890 $ a( n2*n2 ), n2, b( 0, 0 ), ldb )
891*
892 END IF
893*
894 END IF
895*
896 END IF
897*
898 ELSE
899*
900* SIDE = 'R' and N is even
901*
902 IF( normaltransr ) THEN
903*
904* SIDE = 'R', N is even, and TRANSR = 'N'
905*
906 IF( lower ) THEN
907*
908* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L'
909*
910 IF( notrans ) THEN
911*
912* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
913* and TRANS = 'N'
914*
915 CALL ztrsm( 'R', 'U', 'C', diag, m, k, alpha,
916 $ a( 0 ), n+1, b( 0, k ), ldb )
917 CALL zgemm( 'N', 'N', m, k, k, -cone, b( 0, k ),
918 $ ldb, a( k+1 ), n+1, alpha, b( 0, 0 ),
919 $ ldb )
920 CALL ztrsm( 'R', 'L', 'N', diag, m, k, cone,
921 $ a( 1 ), n+1, b( 0, 0 ), ldb )
922*
923 ELSE
924*
925* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L',
926* and TRANS = 'C'
927*
928 CALL ztrsm( 'R', 'L', 'C', diag, m, k, alpha,
929 $ a( 1 ), n+1, b( 0, 0 ), ldb )
930 CALL zgemm( 'N', 'C', m, k, k, -cone, b( 0, 0 ),
931 $ ldb, a( k+1 ), n+1, alpha, b( 0, k ),
932 $ ldb )
933 CALL ztrsm( 'R', 'U', 'N', diag, m, k, cone,
934 $ a( 0 ), n+1, b( 0, k ), ldb )
935*
936 END IF
937*
938 ELSE
939*
940* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U'
941*
942 IF( notrans ) THEN
943*
944* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
945* and TRANS = 'N'
946*
947 CALL ztrsm( 'R', 'L', 'C', diag, m, k, alpha,
948 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
949 CALL zgemm( 'N', 'N', m, k, k, -cone, b( 0, 0 ),
950 $ ldb, a( 0 ), n+1, alpha, b( 0, k ),
951 $ ldb )
952 CALL ztrsm( 'R', 'U', 'N', diag, m, k, cone,
953 $ a( k ), n+1, b( 0, k ), ldb )
954*
955 ELSE
956*
957* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U',
958* and TRANS = 'C'
959*
960 CALL ztrsm( 'R', 'U', 'C', diag, m, k, alpha,
961 $ a( k ), n+1, b( 0, k ), ldb )
962 CALL zgemm( 'N', 'C', m, k, k, -cone, b( 0, k ),
963 $ ldb, a( 0 ), n+1, alpha, b( 0, 0 ),
964 $ ldb )
965 CALL ztrsm( 'R', 'L', 'N', diag, m, k, cone,
966 $ a( k+1 ), n+1, b( 0, 0 ), ldb )
967*
968 END IF
969*
970 END IF
971*
972 ELSE
973*
974* SIDE = 'R', N is even, and TRANSR = 'C'
975*
976 IF( lower ) THEN
977*
978* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'L'
979*
980 IF( notrans ) THEN
981*
982* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L',
983* and TRANS = 'N'
984*
985 CALL ztrsm( 'R', 'L', 'N', diag, m, k, alpha,
986 $ a( 0 ), k, b( 0, k ), ldb )
987 CALL zgemm( 'N', 'C', m, k, k, -cone, b( 0, k ),
988 $ ldb, a( ( k+1 )*k ), k, alpha,
989 $ b( 0, 0 ), ldb )
990 CALL ztrsm( 'R', 'U', 'C', diag, m, k, cone,
991 $ a( k ), k, b( 0, 0 ), ldb )
992*
993 ELSE
994*
995* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L',
996* and TRANS = 'C'
997*
998 CALL ztrsm( 'R', 'U', 'N', diag, m, k, alpha,
999 $ a( k ), k, b( 0, 0 ), ldb )
1000 CALL zgemm( 'N', 'N', m, k, k, -cone, b( 0, 0 ),
1001 $ ldb, a( ( k+1 )*k ), k, alpha,
1002 $ b( 0, k ), ldb )
1003 CALL ztrsm( 'R', 'L', 'C', diag, m, k, cone,
1004 $ a( 0 ), k, b( 0, k ), ldb )
1005*
1006 END IF
1007*
1008 ELSE
1009*
1010* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'U'
1011*
1012 IF( notrans ) THEN
1013*
1014* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U',
1015* and TRANS = 'N'
1016*
1017 CALL ztrsm( 'R', 'U', 'N', diag, m, k, alpha,
1018 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
1019 CALL zgemm( 'N', 'C', m, k, k, -cone, b( 0, 0 ),
1020 $ ldb, a( 0 ), k, alpha, b( 0, k ), ldb )
1021 CALL ztrsm( 'R', 'L', 'C', diag, m, k, cone,
1022 $ a( k*k ), k, b( 0, k ), ldb )
1023*
1024 ELSE
1025*
1026* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U',
1027* and TRANS = 'C'
1028*
1029 CALL ztrsm( 'R', 'L', 'N', diag, m, k, alpha,
1030 $ a( k*k ), k, b( 0, k ), ldb )
1031 CALL zgemm( 'N', 'N', m, k, k, -cone, b( 0, k ),
1032 $ ldb, a( 0 ), k, alpha, b( 0, 0 ), ldb )
1033 CALL ztrsm( 'R', 'U', 'C', diag, m, k, cone,
1034 $ a( ( k+1 )*k ), k, b( 0, 0 ), ldb )
1035*
1036 END IF
1037*
1038 END IF
1039*
1040 END IF
1041*
1042 END IF
1043 END IF
1044*
1045 RETURN
1046*
1047* End of ZTFSM
1048*
1049 END
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:188
ztfsm
subroutine ztfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition ztfsm.f:298
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180