From 8767fb4cb665dc92a9f456112fe9fc42e322ad15 Mon Sep 17 00:00:00 2001 From: james Date: Thu, 27 Jun 2013 18:34:04 +0000 Subject: [PATCH] updated xlarfb routines --- SRC/clarfb.f | 279 +++++++++++++++++++++-------------------------- SRC/dlarfb.f | 298 +++++++++++++++++++++------------------------------ SRC/slarfb.f | 296 +++++++++++++++++++++----------------------------- SRC/zlarfb.f | 282 +++++++++++++++++++++--------------------------- 4 files changed, 493 insertions(+), 662 deletions(-) diff --git a/SRC/clarfb.f b/SRC/clarfb.f index ea378f3a..19d7b81c 100644 --- a/SRC/clarfb.f +++ b/SRC/clarfb.f @@ -159,7 +159,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup complexOTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILACLR, ILACLC - EXTERNAL LSAME, ILACLR, ILACLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMM, CLACGV, CTRMM @@ -255,36 +254,33 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILACLR( M, K, V, LDV ) ) - LASTC = ILACLC( LASTV, N, C, LDC ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C1**H * DO 10 J = 1, K - CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL CLACGV( LASTC, WORK( 1, J ), 1 ) + CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL CLACGV( N, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * - CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * * W := W + C2**H *V2 * - CALL CGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, - $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) + CALL CGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C( K+1, 1 ), LDC, + $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -293,19 +289,19 @@ * C2 := C2 - V2 * W**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV, - $ WORK, LDWORK, ONE, C( K+1, 1 ), LDC ) + $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, + $ LDWORK, ONE, C( K+1, 1 ), LDC ) END IF * * W := W * V1**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE @@ -313,58 +309,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTV = MAX( K, ILACLR( N, K, V, LDV ) ) - LASTC = ILACLR( M, LASTV, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K - CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * - CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2 * - CALL CGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2**H * - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL CGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), + $ LDV, ONE, C( 1, K+1 ), LDC ) END IF * * W := W * V1**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -379,38 +370,34 @@ IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H**H * C where C = ( C1 ) -* ( C2 ) -* - LASTC = ILACLC( M, N, C, LDC ) +* ( C2 ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C2**H * DO 70 J = 1, K - CALL CCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL CLACGV( LASTC, WORK( 1, J ), 1 ) + CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL CLACGV( N, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**H*V1 +* W := W + C1**H * V1 * - CALL CGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL CGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) END IF * * W := W * T**H or W * T * - CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -419,20 +406,20 @@ * C1 := C1 - V1 * W**H * CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) END IF * * W := W * V2**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W**H * DO 90 J = 1, K - DO 80 I = 1, LASTC + DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ CONJG( WORK( I, J ) ) 80 CONTINUE @@ -441,36 +428,31 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILACLR( M, N, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL CCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL CGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + CALL CGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * @@ -478,23 +460,22 @@ * * C1 := C1 - W * V1**H * - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL CGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, + $ C, LDC ) END IF * * W := W * V2**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - $ - WORK( I, J ) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -511,59 +492,56 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILACLC( K, M, V, LDV ) ) - LASTC = ILACLC( LASTV, N, C, LDC ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C1**H * DO 130 J = 1, K - CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL CLACGV( LASTC, WORK( 1, J ), 1 ) + CALL CCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL CLACGV( N, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**H*V2**H +* W := W + C2**H * V2**H * CALL CGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2**H * W**H * CALL CGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + $ 'Conjugate transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * - CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE @@ -571,57 +549,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTV = MAX( K, ILACLC( K, N, V, LDV ) ) - LASTC = ILACLR( M, LASTV, C, LDC ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C1 * DO 160 J = 1, K - CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL CCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**H * CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2**H * - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, - $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) + CALL CGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C( 1, K+1 ), LDC, + $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * - CALL CGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * - CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -637,37 +611,34 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILACLC( M, N, C, LDC ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C2**H * DO 190 J = 1, K - CALL CCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL CLACGV( LASTC, WORK( 1, J ), 1 ) + CALL CCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL CLACGV( N, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, + $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1**H * CALL CGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-K, ONE, C, + $ LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * @@ -676,20 +647,19 @@ * C1 := C1 - V1**H * W**H * CALL CGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, LASTC, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + $ 'Conjugate transpose', M-K, N, K, -ONE, V, + $ LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * - CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**H * DO 210 J = 1, K - DO 200 I = 1, LASTC + DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ CONJG( WORK( I, J ) ) 200 CONTINUE @@ -698,36 +668,33 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILACLR( M, N, C, LDC ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C2 * DO 220 J = 1, K - CALL CCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL CCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**H * CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, + $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**H * - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE, - $ WORK, LDWORK ) + CALL CGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) END IF * * W := W * T or W * T**H * - CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -735,21 +702,19 @@ * * C1 := C1 - W * V1 * - CALL CGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL CGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * - CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC + DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE diff --git a/SRC/dlarfb.f b/SRC/dlarfb.f index 17218478..18ec9bfd 100644 --- a/SRC/dlarfb.f +++ b/SRC/dlarfb.f @@ -159,7 +159,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup doubleOTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC, lastv2 + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILADLR, ILADLC - EXTERNAL LSAME, ILADLR, ILADLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM @@ -252,58 +251,53 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILADLR( M, K, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C1**T * DO 10 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T *V2 +* W := W + C2**T * V2 * - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE @@ -311,58 +305,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLR( N, K, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -378,36 +367,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILADLC( M, N, C, LDC ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C2**T * DO 70 J = 1, K - CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**T*V1 +* W := W + C1**T * V1 * - CALL DGEMM( 'Transpose', 'No transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * @@ -415,57 +399,51 @@ * * C1 := C1 - V1 * W**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2**T * - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 90 J = 1, K - DO 80 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTC = ILADLR( M, N, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * @@ -473,22 +451,20 @@ * * C1 := C1 - W * V1**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2**T * - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -505,58 +481,53 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILADLC( K, M, V, LDV ) ) - LASTC = ILADLC( LASTV, N, C, LDC ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C1**T * DO 130 J = 1, K - CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**T * - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T*V2**T +* W := W + C2**T * V2**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2**T * W**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE @@ -564,58 +535,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILADLC( K, N, V, LDV ) ) - LASTC = ILADLR( M, LASTV, C, LDC ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C1 * DO 160 J = 1, K - CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**T * - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -631,36 +597,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILADLC( M, N, C, LDC ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C2**T * DO 190 J = 1, K - CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * @@ -668,58 +629,51 @@ * * C1 := C1 - V1**T * W**T * - CALL DGEMM( 'Transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 210 J = 1, K - DO 200 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTC = ILADLR( M, N, C, LDC ) +* Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C2 * DO 220 J = 1, K - CALL DCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**T * - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**T * - CALL DGEMM( 'No transpose', 'Transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -727,22 +681,20 @@ * * C1 := C1 - W * V1 * - CALL DGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J) + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * diff --git a/SRC/slarfb.f b/SRC/slarfb.f index 7694801e..78b121d2 100644 --- a/SRC/slarfb.f +++ b/SRC/slarfb.f @@ -159,7 +159,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup realOTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILASLR, ILASLC - EXTERNAL LSAME, ILASLR, ILASLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEMM, STRMM @@ -252,58 +251,53 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILASLR( M, K, V, LDV ) ) - LASTC = ILASLC( LASTV, N, C, LDC ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C1**T * DO 10 J = 1, K - CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * - CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T *V2 +* W := W + C2**T * V2 * - CALL SGEMM( 'Transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2 * W**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) + CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1**T * - CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE @@ -311,58 +305,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILASLR( N, K, V, LDV ) ) - LASTC = ILASLR( M, LASTV, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K - CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * - CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2 * - CALL SGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) + CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1**T * - CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -378,36 +367,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILASLC( M, N, C, LDC ) * * W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) * * W := C2**T * DO 70 J = 1, K - CALL SCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**T*V1 +* W := W + C1**T * V1 * - CALL SGEMM( 'Transpose', 'No transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**T * @@ -415,57 +399,51 @@ * * C1 := C1 - V1 * W**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2**T * - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 90 J = 1, K - DO 80 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * -* Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTC = ILASLR( M, N, C, LDC ) +* Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL SGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**T * @@ -473,22 +451,20 @@ * * C1 := C1 - W * V1**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2**T * - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -505,58 +481,53 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILASLC( K, M, V, LDV ) ) - LASTC = ILASLC( LASTV, N, C, LDC ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C1**T * DO 130 J = 1, K - CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**T * - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**T*V2**T +* W := W + C2**T * V2**T * - CALL SGEMM( 'Transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2**T * W**T * - CALL SGEMM( 'Transpose', 'Transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * - CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**T * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE @@ -564,58 +535,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTV = MAX( K, ILASLC( K, N, V, LDV ) ) - LASTC = ILASLR( M, LASTV, C, LDC ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C1 * DO 160 J = 1, K - CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**T * - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * - CALL SGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * - CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -631,36 +597,31 @@ * * Form H * C or H**T * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILASLC( M, N, C, LDC ) * * W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) * * W := C2**T * DO 190 J = 1, K - CALL SCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) + CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**T * - CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**T * V1**T * - CALL SGEMM( 'Transpose', 'Transpose', - $ LASTC, K, M-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**T or W * T * - CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**T * W**T * @@ -668,58 +629,51 @@ * * C1 := C1 - V1**T * W**T * - CALL SGEMM( 'Transpose', 'Transpose', - $ M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * - CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**T * DO 210 J = 1, K - DO 200 I = 1, LASTC - C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J) + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**T where C = ( C1 C2 ) -* - LASTC = ILASLR( M, N, C, LDC ) * * W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) * * W := C2 * DO 220 J = 1, K - CALL SCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**T * - CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**T * - CALL SGEMM( 'No transpose', 'Transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**T * - CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -727,21 +681,19 @@ * * C1 := C1 - W * V1 * - CALL SGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * - CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC + DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE diff --git a/SRC/zlarfb.f b/SRC/zlarfb.f index 99490f58..480f543f 100644 --- a/SRC/zlarfb.f +++ b/SRC/zlarfb.f @@ -159,7 +159,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date September 2012 +*> \date June 2013 * *> \ingroup complex16OTHERauxiliary * @@ -195,10 +195,10 @@ SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK auxiliary routine (version 3.4.2) -- +* -- LAPACK auxiliary routine (version 3.5.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* September 2012 +* June 2013 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS @@ -217,12 +217,11 @@ * .. * .. Local Scalars .. CHARACTER TRANST - INTEGER I, J, LASTV, LASTC + INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME - INTEGER ILAZLR, ILAZLC - EXTERNAL LSAME, ILAZLR, ILAZLC + EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM @@ -255,36 +254,33 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILAZLR( M, K, V, LDV ) ) - LASTC = ILAZLC( LASTV, N, C, LDC ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C1**H * DO 10 J = 1, K - CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**H *V2 +* W := W + C2**H * V2 * - CALL ZGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC, - $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) + CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C( K+1, 1 ), LDC, + $ V( K+1, 1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -293,20 +289,19 @@ * C2 := C2 - V2 * W**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTV-K, LASTC, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, + $ LDWORK, ONE, C( K+1, 1 ), LDC ) END IF * * W := W * V1**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 30 J = 1, K - DO 20 I = 1, LASTC + DO 20 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE @@ -314,58 +309,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTV = MAX( K, ILAZLR( N, K, V, LDV ) ) - LASTC = ILAZLR( M, LASTV, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K - CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, K, LASTV-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ), + $ LDV, ONE, C( 1, K+1 ), LDC ) END IF * * W := W * V1**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K - DO 50 I = 1, LASTC + DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE @@ -381,38 +371,33 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILAZLC( M, N, C, LDC ) * * W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) * * W := C2**H * DO 70 J = 1, K - CALL ZCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 70 CONTINUE * * W := W * V2 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * -* W := W + C1**H*V1 +* W := W + C1**H * V1 * - CALL ZGEMM( 'Conjugate transpose', 'No transpose', - $ LASTC, K, M-K, - $ ONE, C, LDC, V, LDV, - $ ONE, WORK, LDWORK ) + CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, + $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) END IF * * W := W * T**H or W * T * - CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W**H * @@ -421,21 +406,20 @@ * C1 := C1 - V1 * W**H * CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ M-K, LASTC, K, - $ -ONE, V, LDV, WORK, LDWORK, - $ ONE, C, LDC ) + $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, + $ ONE, C, LDC ) END IF * * W := W * V2**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( M-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W**H * DO 90 J = 1, K - DO 80 I = 1, LASTC + DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 80 CONTINUE @@ -444,36 +428,31 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILAZLR( M, N, C, LDC ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K - CALL ZCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V**H * @@ -481,23 +460,22 @@ * * C1 := C1 - W * V1**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, + $ C, LDC ) END IF * * W := W * V2**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( N-K+1, 1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK, + $ LDWORK ) * * C2 := C2 - W * DO 120 J = 1, K - DO 110 I = 1, LASTC - C( I, N-K+J ) = C( I, N-K+J ) - $ - WORK( I, J ) + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF @@ -514,59 +492,56 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTV = MAX( K, ILAZLC( K, M, V, LDV ) ) - LASTC = ILAZLC( LASTV, N, C, LDC ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C1**H * DO 130 J = 1, K - CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN * -* W := W + C2**H*V2**H +* W := W + C2**H * V2**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, LASTV-K, - $ ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * - IF( LASTV.GT.K ) THEN + IF( M.GT.K ) THEN * * C2 := C2 - V2**H * W**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTV-K, LASTC, K, - $ -ONE, V( 1, K+1 ), LDV, WORK, LDWORK, - $ ONE, C( K+1, 1 ), LDC ) + $ 'Conjugate transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) END IF * * W := W * V1 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W**H * DO 150 J = 1, K - DO 140 I = 1, LASTC + DO 140 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE @@ -574,57 +549,53 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTV = MAX( K, ILAZLC( K, N, V, LDV ) ) - LASTC = ILAZLR( M, LASTV, C, LDC ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C1 * DO 160 J = 1, K - CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1**H * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK ) - IF( LASTV.GT.K ) THEN + $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN * * W := W + C2 * V2**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC, - $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C( 1, K+1 ), LDC, + $ V( 1, K+1 ), LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T**H * - CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * - IF( LASTV.GT.K ) THEN + IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, LASTV-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, - $ ONE, C( 1, K+1 ), LDC ) + CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) END IF * * W := W * V1 * - CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', - $ LASTC, K, ONE, V, LDV, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K - DO 170 I = 1, LASTC + DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE @@ -640,37 +611,34 @@ * * Form H * C or H**H * C where C = ( C1 ) * ( C2 ) -* - LASTC = ILAZLC( M, N, C, LDC ) * * W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) * * W := C2**H * DO 190 J = 1, K - CALL ZCOPY( LASTC, C( M-K+J, 1 ), LDC, - $ WORK( 1, J ), 1 ) - CALL ZLACGV( LASTC, WORK( 1, J ), 1 ) + CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + CALL ZLACGV( N, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, + $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1**H * V1**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', LASTC, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + $ 'Conjugate transpose', N, K, M-K, ONE, C, + $ LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T**H or W * T * - CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V**H * W**H * @@ -679,20 +647,19 @@ * C1 := C1 - V1**H * W**H * CALL ZGEMM( 'Conjugate transpose', - $ 'Conjugate transpose', M-K, LASTC, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + $ 'Conjugate transpose', M-K, N, K, -ONE, V, + $ LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2 * - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, M-K+1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W**H * DO 210 J = 1, K - DO 200 I = 1, LASTC + DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 200 CONTINUE @@ -701,36 +668,33 @@ ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H**H where C = ( C1 C2 ) -* - LASTC = ILAZLR( M, N, C, LDC ) * * W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) * * W := C2 * DO 220 J = 1, K - CALL ZCOPY( LASTC, C( 1, N-K+J ), 1, - $ WORK( 1, J ), 1 ) + CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2**H * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Unit', LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, + $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1**H * - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ LASTC, K, N-K, ONE, C, LDC, V, LDV, ONE, - $ WORK, LDWORK ) + CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, + $ K, N-K, ONE, C, LDC, V, LDV, ONE, WORK, + $ LDWORK ) END IF * * W := W * T or W * T**H * - CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', - $ LASTC, K, ONE, T, LDT, WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * @@ -738,21 +702,19 @@ * * C1 := C1 - W * V1 * - CALL ZGEMM( 'No transpose', 'No transpose', - $ LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV, - $ ONE, C, LDC ) + CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2 * - CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', - $ LASTC, K, ONE, V( 1, N-K+1 ), LDV, - $ WORK, LDWORK ) + CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K - DO 230 I = 1, LASTC + DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE -- 2.34.1