195 SUBROUTINE clarfb( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
196 $ t, ldt, c, ldc, work, ldwork )
204 CHARACTER direct, side, storev, trans
205 INTEGER k, ldc, ldt, ldv, ldwork, m, n
208 COMPLEX c( ldc, * ), t( ldt, * ), v( ldv, * ),
216 parameter( one = ( 1.0e+0, 0.0e+0 ) )
220 INTEGER i, j, lastv, lastc
237 IF( m.LE.0 .OR. n.LE.0 )
240 IF(
lsame( trans,
'N' ) )
THEN
246 IF(
lsame( storev,
'C' ) )
THEN
248 IF(
lsame( direct,
'F' ) )
THEN
254 IF(
lsame( side,
'L' ) )
THEN
259 lastv = max( k,
ilaclr( m, k, v, ldv ) )
260 lastc =
ilaclc( lastv, n, c, ldc )
267 CALL
ccopy( lastc, c( j, 1 ), ldc, work( 1, j ), 1 )
268 CALL
clacgv( lastc, work( 1, j ), 1 )
273 CALL
ctrmm(
'Right',
'Lower',
'No transpose',
'Unit',
274 $ lastc, k, one, v, ldv, work, ldwork )
275 IF( lastv.GT.k )
THEN
279 CALL
cgemm(
'Conjugate transpose',
'No transpose',
280 $ lastc, k, lastv-k, one, c( k+1, 1 ), ldc,
281 $ v( k+1, 1 ), ldv, one, work, ldwork )
286 CALL
ctrmm(
'Right',
'Upper', transt,
'Non-unit',
287 $ lastc, k, one, t, ldt, work, ldwork )
295 CALL
cgemm(
'No transpose',
'Conjugate transpose',
296 $ lastv-k, lastc, k, -one, v( k+1, 1 ), ldv,
297 $ work, ldwork, one, c( k+1, 1 ), ldc )
302 CALL
ctrmm(
'Right',
'Lower',
'Conjugate transpose',
303 $
'Unit', lastc, k, one, v, ldv, work, ldwork )
309 c( j, i ) = c( j, i ) - conjg( work( i, j ) )
313 ELSE IF(
lsame( side,
'R' ) )
THEN
317 lastv = max( k,
ilaclr( n, k, v, ldv ) )
318 lastc =
ilaclr( m, lastv, c, ldc )
325 CALL
ccopy( lastc, c( 1, j ), 1, work( 1, j ), 1 )
330 CALL
ctrmm(
'Right',
'Lower',
'No transpose',
'Unit',
331 $ lastc, k, one, v, ldv, work, ldwork )
332 IF( lastv.GT.k )
THEN
336 CALL
cgemm(
'No transpose',
'No transpose',
338 $ one, c( 1, k+1 ), ldc, v( k+1, 1 ), ldv,
339 $ one, work, ldwork )
344 CALL
ctrmm(
'Right',
'Upper', trans,
'Non-unit',
345 $ lastc, k, one, t, ldt, work, ldwork )
349 IF( lastv.GT.k )
THEN
353 CALL
cgemm(
'No transpose',
'Conjugate transpose',
355 $ -one, work, ldwork, v( k+1, 1 ), ldv,
356 $ one, c( 1, k+1 ), ldc )
361 CALL
ctrmm(
'Right',
'Lower',
'Conjugate transpose',
362 $
'Unit', lastc, k, one, v, ldv, work, ldwork )
368 c( i, j ) = c( i, j ) - work( i, j )
379 IF(
lsame( side,
'L' ) )
THEN
384 lastc =
ilaclc( m, n, c, ldc )
391 CALL
ccopy( lastc, c( m-k+j, 1 ), ldc,
393 CALL
clacgv( lastc, work( 1, j ), 1 )
398 CALL
ctrmm(
'Right',
'Upper',
'No transpose',
'Unit',
399 $ lastc, k, one, v( m-k+1, 1 ), ldv,
405 CALL
cgemm(
'Conjugate transpose',
'No transpose',
406 $ lastc, k, m-k, one, c, ldc, v, ldv,
407 $ one, work, ldwork )
412 CALL
ctrmm(
'Right',
'Lower', transt,
'Non-unit',
413 $ lastc, k, one, t, ldt, work, ldwork )
421 CALL
cgemm(
'No transpose',
'Conjugate transpose',
422 $ m-k, lastc, k, -one, v, ldv, work, ldwork,
428 CALL
ctrmm(
'Right',
'Upper',
'Conjugate transpose',
429 $
'Unit', lastc, k, one, v( m-k+1, 1 ), ldv,
436 c( m-k+j, i ) = c( m-k+j, i ) -
437 $ conjg( work( i, j ) )
441 ELSE IF(
lsame( side,
'R' ) )
THEN
445 lastc =
ilaclr( m, n, c, ldc )
452 CALL
ccopy( lastc, c( 1, n-k+j ), 1,
458 CALL
ctrmm(
'Right',
'Upper',
'No transpose',
'Unit',
459 $ lastc, k, one, v( n-k+1, 1 ), ldv,
465 CALL
cgemm(
'No transpose',
'No transpose',
467 $ one, c, ldc, v, ldv, one, work, ldwork )
472 CALL
ctrmm(
'Right',
'Lower', trans,
'Non-unit',
473 $ lastc, k, one, t, ldt, work, ldwork )
481 CALL
cgemm(
'No transpose',
'Conjugate transpose',
482 $ lastc, n-k, k, -one, work, ldwork, v, ldv,
488 CALL
ctrmm(
'Right',
'Upper',
'Conjugate transpose',
489 $
'Unit', lastc, k, one, v( n-k+1, 1 ), ldv,
496 c( i, n-k+j ) = c( i, n-k+j )
503 ELSE IF(
lsame( storev,
'R' ) )
THEN
505 IF(
lsame( direct,
'F' ) )
THEN
510 IF(
lsame( side,
'L' ) )
THEN
515 lastv = max( k,
ilaclc( k, m, v, ldv ) )
516 lastc =
ilaclc( lastv, n, c, ldc )
523 CALL
ccopy( lastc, c( j, 1 ), ldc, work( 1, j ), 1 )
524 CALL
clacgv( lastc, work( 1, j ), 1 )
529 CALL
ctrmm(
'Right',
'Upper',
'Conjugate transpose',
530 $
'Unit', lastc, k, one, v, ldv, work, ldwork )
531 IF( lastv.GT.k )
THEN
535 CALL
cgemm(
'Conjugate transpose',
536 $
'Conjugate transpose', lastc, k, lastv-k,
537 $ one, c( k+1, 1 ), ldc, v( 1, k+1 ), ldv,
538 $ one, work, ldwork )
543 CALL
ctrmm(
'Right',
'Upper', transt,
'Non-unit',
544 $ lastc, k, one, t, ldt, work, ldwork )
548 IF( lastv.GT.k )
THEN
552 CALL
cgemm(
'Conjugate transpose',
553 $
'Conjugate transpose', lastv-k, lastc, k,
554 $ -one, v( 1, k+1 ), ldv, work, ldwork,
555 $ one, c( k+1, 1 ), ldc )
560 CALL
ctrmm(
'Right',
'Upper',
'No transpose',
'Unit',
561 $ lastc, k, one, v, ldv, work, ldwork )
567 c( j, i ) = c( j, i ) - conjg( work( i, j ) )
571 ELSE IF(
lsame( side,
'R' ) )
THEN
575 lastv = max( k,
ilaclc( k, n, v, ldv ) )
576 lastc =
ilaclr( m, lastv, c, ldc )
583 CALL
ccopy( lastc, c( 1, j ), 1, work( 1, j ), 1 )
588 CALL
ctrmm(
'Right',
'Upper',
'Conjugate transpose',
589 $
'Unit', lastc, k, one, v, ldv, work, ldwork )
590 IF( lastv.GT.k )
THEN
594 CALL
cgemm(
'No transpose',
'Conjugate transpose',
595 $ lastc, k, lastv-k, one, c( 1, k+1 ), ldc,
596 $ v( 1, k+1 ), ldv, one, work, ldwork )
601 CALL
ctrmm(
'Right',
'Upper', trans,
'Non-unit',
602 $ lastc, k, one, t, ldt, work, ldwork )
606 IF( lastv.GT.k )
THEN
610 CALL
cgemm(
'No transpose',
'No transpose',
612 $ -one, work, ldwork, v( 1, k+1 ), ldv,
613 $ one, c( 1, k+1 ), ldc )
618 CALL
ctrmm(
'Right',
'Upper',
'No transpose',
'Unit',
619 $ lastc, k, one, v, ldv, work, ldwork )
625 c( i, j ) = c( i, j ) - work( i, j )
636 IF(
lsame( side,
'L' ) )
THEN
641 lastc =
ilaclc( m, n, c, ldc )
648 CALL
ccopy( lastc, c( m-k+j, 1 ), ldc,
650 CALL
clacgv( lastc, work( 1, j ), 1 )
655 CALL
ctrmm(
'Right',
'Lower',
'Conjugate transpose',
656 $
'Unit', lastc, k, one, v( 1, m-k+1 ), ldv,
662 CALL
cgemm(
'Conjugate transpose',
663 $
'Conjugate transpose', lastc, k, m-k,
664 $ one, c, ldc, v, ldv, one, work, ldwork )
669 CALL
ctrmm(
'Right',
'Lower', transt,
'Non-unit',
670 $ lastc, k, one, t, ldt, work, ldwork )
678 CALL
cgemm(
'Conjugate transpose',
679 $
'Conjugate transpose', m-k, lastc, k,
680 $ -one, v, ldv, work, ldwork, one, c, ldc )
685 CALL
ctrmm(
'Right',
'Lower',
'No transpose',
'Unit',
686 $ lastc, k, one, v( 1, m-k+1 ), ldv,
693 c( m-k+j, i ) = c( m-k+j, i ) -
694 $ conjg( work( i, j ) )
698 ELSE IF(
lsame( side,
'R' ) )
THEN
702 lastc =
ilaclr( m, n, c, ldc )
709 CALL
ccopy( lastc, c( 1, n-k+j ), 1,
715 CALL
ctrmm(
'Right',
'Lower',
'Conjugate transpose',
716 $
'Unit', lastc, k, one, v( 1, n-k+1 ), ldv,
722 CALL
cgemm(
'No transpose',
'Conjugate transpose',
723 $ lastc, k, n-k, one, c, ldc, v, ldv, one,
729 CALL
ctrmm(
'Right',
'Lower', trans,
'Non-unit',
730 $ lastc, k, one, t, ldt, work, ldwork )
738 CALL
cgemm(
'No transpose',
'No transpose',
739 $ lastc, n-k, k, -one, work, ldwork, v, ldv,
745 CALL
ctrmm(
'Right',
'Lower',
'No transpose',
'Unit',
746 $ lastc, k, one, v( 1, n-k+1 ), ldv,
753 c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )