SUBROUTINE MB04QC( STRUCT, TRANA, TRANB, TRANQ, DIRECT, STOREV, $ STOREW, M, N, K, V, LDV, W, LDW, RS, LDRS, T, $ LDT, A, LDA, B, LDB, DWORK ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2009 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To apply the orthogonal symplectic block reflector C C [ I+V*T*V' V*R*S*V' ] C Q = [ ] C [ -V*R*S*V' I+V*T*V' ] C C or its transpose to a real 2m-by-n matrix [ op(A); op(B) ] from C the left. C The k-by-k upper triangular blocks of the matrices C C [ S1 ] [ T11 T12 T13 ] C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], C [ S3 ] [ T31 T32 T33 ] C C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, C are stored rowwise in the arrays RS and T, respectively. C C ARGUMENTS C C Mode Parameters C C STRUCT CHARACTER*1 C Specifies the structure of the first blocks of A and B: C = 'Z': the leading K-by-N submatrices of op(A) and op(B) C are (implicitly) assumed to be zero; C = 'N'; no structure to mention. C C TRANA CHARACTER*1 C Specifies the form of op( A ) as follows: C = 'N': op( A ) = A; C = 'T': op( A ) = A'; C = 'C': op( A ) = A'. C C TRANB CHARACTER*1 C Specifies the form of op( B ) as follows: C = 'N': op( B ) = B; C = 'T': op( B ) = B'; C = 'C': op( B ) = B'. C C DIRECT CHARACTER*1 C This is a dummy argument, which is reserved for future C extensions of this subroutine. Not referenced. C C TRANQ CHARACTER*1 C = 'N': apply Q; C = 'T': apply Q'. C C STOREV CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder reflectors contained in V are stored: C = 'C': columnwise; C = 'R': rowwise. C C STOREW CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder reflectors contained in W are stored: C = 'C': columnwise; C = 'R': rowwise. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrices op(A) and op(B). C M >= 0. C C N (input) INTEGER C The number of columns of the matrices op(A) and op(B). C N >= 0. C C K (input) INTEGER C The order of the triangular matrices defining R, S and T. C M >= K >= 0. C C V (input) DOUBLE PRECISION array, dimension C (LDV,K) if STOREV = 'C', C (LDV,M) if STOREV = 'R' C On entry with STOREV = 'C', the leading M-by-K part of C this array must contain in its columns the vectors which C define the elementary reflector used to form parts of Q. C On entry with STOREV = 'R', the leading K-by-M part of C this array must contain in its rows the vectors which C define the elementary reflector used to form parts of Q. C C LDV INTEGER C The leading dimension of the array V. C LDV >= MAX(1,M), if STOREV = 'C'; C LDV >= MAX(1,K), if STOREV = 'R'. C C W (input) DOUBLE PRECISION array, dimension C (LDW,K) if STOREW = 'C', C (LDW,M) if STOREW = 'R' C On entry with STOREW = 'C', the leading M-by-K part of C this array must contain in its columns the vectors which C define the elementary reflector used to form parts of Q. C On entry with STOREW = 'R', the leading K-by-M part of C this array must contain in its rows the vectors which C define the elementary reflector used to form parts of Q. C C LDW INTEGER C The leading dimension of the array W. C LDW >= MAX(1,M), if STOREW = 'C'; C LDW >= MAX(1,K), if STOREW = 'R'. C C RS (input) DOUBLE PRECISION array, dimension (K,6*K) C On entry, the leading K-by-6*K part of this array must C contain the upper triangular matrices defining the factors C R and S of the symplectic block reflector Q. The C (strictly) lower portions of this array are not C referenced. C C LDRS INTEGER C The leading dimension of the array RS. LDRS >= MAX(1,K). C C T (input) DOUBLE PRECISION array, dimension (K,9*K) C On entry, the leading K-by-9*K part of this array must C contain the upper triangular matrices defining the factor C T of the symplectic block reflector Q. The (strictly) C lower portions of this array are not referenced. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1,K). C C A (input/output) DOUBLE PRECISION array, dimension C (LDA,N) if TRANA = 'N', C (LDA,M) if TRANA = 'C' or TRANA = 'T' C On entry with TRANA = 'N', the leading M-by-N part of this C array must contain the matrix A. C On entry with TRANA = 'T' or TRANA = 'C', the leading C N-by-M part of this array must contain the matrix A. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,M), if TRANA = 'N'; C LDA >= MAX(1,N), if TRANA = 'C' or TRANA = 'T'. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,N) if TRANB = 'N', C (LDB,M) if TRANB = 'C' or TRANB = 'T' C On entry with TRANB = 'N', the leading M-by-N part of this C array must contain the matrix B. C On entry with TRANB = 'T' or TRANB = 'C', the leading C N-by-M part of this array must contain the matrix B. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,M), if TRANB = 'N'; C LDB >= MAX(1,N), if TRANB = 'C' or TRANB = 'T'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK), where C LDWORK >= 8*N*K, if STRUCT = 'Z', C LDWORK >= 9*N*K, if STRUCT = 'N'. C C REFERENCES C C [1] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C NUMERICAL ASPECTS C C The algorithm requires 16*( M - K )*N + ( 26*K - 4 )*K*N floating C point operations if STRUCT = 'Z' and additional ( 12*K + 2 )*K*N C floating point operations if STRUCT = 'N'. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAESB). C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DIRECT, STOREV, STOREW, STRUCT, TRANA, TRANB, $ TRANQ INTEGER K, LDA, LDB, LDRS, LDT, LDV, LDW, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), RS(LDRS,*), $ T(LDT,*), V(LDV,*), W(LDW,*) C .. Local Scalars .. LOGICAL LA1B1, LCOLV, LCOLW, LTRA, LTRB, LTRQ INTEGER I, ITEMP, PDW1, PDW2, PDW3, PDW4, PDW5, PDW6, $ PDW7, PDW8, PDW9, PR1, PR2, PR3, PS1, PS2, PS3, $ PT11, PT12, PT13, PT21, PT22, PT23, PT31, PT32, $ PT33 DOUBLE PRECISION FACT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DLASET, DTRMM C C .. Executable Statements .. C C Quick return if possible. C IF ( M.LE.0 .OR. N.LE.0 ) $ RETURN LA1B1 = LSAME( STRUCT, 'N' ) LCOLV = LSAME( STOREV, 'C' ) LCOLW = LSAME( STOREW, 'C' ) LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) LTRQ = LSAME( TRANQ, 'T' ) .OR. LSAME( TRANQ, 'C' ) C PR1 = 1 PR2 = PR1 + K PR3 = PR2 + K PS1 = PR3 + K PS2 = PS1 + K PS3 = PS2 + K PT11 = 1 PT12 = PT11 + K PT13 = PT12 + K PT21 = PT13 + K PT22 = PT21 + K PT23 = PT22 + K PT31 = PT23 + K PT32 = PT31 + K PT33 = PT32 + K PDW1 = 1 PDW2 = PDW1 + N*K PDW3 = PDW2 + N*K PDW4 = PDW3 + N*K PDW5 = PDW4 + N*K PDW6 = PDW5 + N*K PDW7 = PDW6 + N*K PDW8 = PDW7 + N*K PDW9 = PDW8 + N*K C C Update the matrix A. C IF ( LA1B1 ) THEN C C NZ1) DW7 := A1' C IF ( LTRA ) THEN DO 10 I = 1, K CALL DCOPY( N, A(1,I), 1, DWORK(PDW7+(I-1)*N), 1 ) 10 CONTINUE ELSE DO 20 I = 1, N CALL DCOPY( K, A(1,I), 1, DWORK(PDW7+I-1), N ) 20 CONTINUE END IF C C NZ2) DW1 := DW7*W1 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW1), 1 ) IF ( LCOLW ) THEN CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, W, LDW, DWORK(PDW1), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, $ K, ONE, W, LDW, DWORK(PDW1), N ) END IF C C NZ3) DW2 := DW7*V1 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW2), 1 ) IF ( LCOLV ) THEN CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, DWORK(PDW2), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, $ K, ONE, V, LDV, DWORK(PDW2), N ) END IF FACT = ONE ELSE FACT = ZERO END IF C C 1) DW1 := A2'*W2 C IF ( M.GT.K ) THEN IF ( LTRA.AND.LCOLW ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, $ A(1,K+1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), $ N ) ELSE IF ( LTRA ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, $ A(1,K+1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), $ N ) ELSE IF ( LCOLW ) THEN CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, $ A(K+1,1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), $ N ) ELSE CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ A(K+1,1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), $ N ) END IF ELSE IF ( .NOT.LA1B1 ) THEN CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) END IF C C 2) DW2 := A2'*V2 C IF ( M.GT.K ) THEN IF ( LTRA.AND.LCOLV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, $ A(1,K+1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), $ N ) ELSE IF ( LTRA ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, $ A(1,K+1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), $ N ) ELSE IF ( LCOLV ) THEN CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, $ A(K+1,1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), $ N ) ELSE CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ A(K+1,1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), $ N ) END IF ELSE IF ( .NOT.LA1B1 ) THEN CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW2), N ) END IF C IF ( LTRQ ) THEN C C 3) DW3 := DW1*T11 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) C C 4) DW4 := DW2*T31 C CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) C C 5) DW3 := DW3 + DW4 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) C IF ( LA1B1 ) THEN C C NZ4) DW8 := DW7*T21 C CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) C C NZ5) DW3 := DW3 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) END IF C C 6) DW4 := DW1*T12 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT12), LDT, DWORK(PDW4), N ) C C 7) DW5 := DW2*T32 C CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) C C 8) DW4 := DW4 + DW5 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) C IF ( LA1B1 ) THEN C C NZ6) DW8 := DW7*T22 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) C C NZ7) DW4 := DW4 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) END IF C C 9) DW5 := DW2*T33 C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) C C 10) DW6 := DW1*T13 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW6), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT13), LDT, DWORK(PDW6), N ) C C 11) DW5 := DW5 + DW6 C CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) C IF ( LA1B1 ) THEN C C NZ8) DW8 := DW7*T23 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT23), LDT, DWORK(PDW8), N ) C C NZ9) DW5 := DW5 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) END IF C C 12) DW1 := DW1*R1 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PR1), LDRS, DWORK(PDW1), N ) C C 13) DW2 := DW2*R3 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW2), N ) C C 14) DW1 := DW1 + DW2 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW2), 1, DWORK(PDW1+N), 1 ) C IF ( LA1B1 ) THEN C C NZ10) DW7 := DW7*R2 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) C C NZ11) DW1 := DW1 + DW7 C CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW1), 1 ) END IF C C Swap Pointers PDW1 <-> PDW2 C ITEMP = PDW2 PDW2 = PDW1 PDW1 = ITEMP ELSE C C 3) DW3 := DW1*T11' C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) C C 4) DW4 := DW2*T13' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) C C 5) DW3 := DW3 + DW4 C CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) C IF ( LA1B1 ) THEN C C NZ4) DW8 := DW7*T12' C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) C C NZ5) DW3 := DW3 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) END IF C C 6) DW4 := DW2*T23' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) C C 7) DW5 := DW1*T21' C CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) C C 8) DW4 := DW4 + DW5 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C IF ( LA1B1 ) THEN C C NZ6) DW8 := DW7*T22' C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) C C NZ7) DW4 := DW4 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) END IF C C 9) DW5 := DW2*T33' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) C C 10) DW6 := DW1*T31' C CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, T(1,PT31+1), LDT, DWORK(PDW6), N ) C C 11) DW5 := DW5 + DW6 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) C IF ( LA1B1 ) THEN C C NZ8) DW8 := DW7*T32' C CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW8), N ) C C NZ9) DW5 := DW5 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) END IF C C 12) DW1 := DW1*S1' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW1+N), N ) C C 13) DW2 := DW2*S3' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) C C 14) DW2 := DW1 + DW2 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW2), 1 ) C IF ( LA1B1 ) THEN C C NZ10) DW7 := DW7*S2' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) C C NZ11) DW2 := DW2 + DW7 C CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW2), 1 ) END IF END IF C IF ( LA1B1 ) THEN C C NZ12) DW9 := B1' C IF ( LTRB ) THEN DO 30 I = 1, K CALL DCOPY( N, B(1,I), 1, DWORK(PDW9+(I-1)*N), 1 ) 30 CONTINUE ELSE DO 40 I = 1, N CALL DCOPY( K, B(1,I), 1, DWORK(PDW9+I-1), N ) 40 CONTINUE END IF C C NZ13) DW1 := DW9*W1 C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW1), 1 ) IF ( LCOLW ) THEN CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, W, LDW, DWORK(PDW1), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, $ K, ONE, W, LDW, DWORK(PDW1), N ) END IF C C NZ14) DW6 := DW9*V1 C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW6), 1 ) IF ( LCOLV ) THEN CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, DWORK(PDW6), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, $ K, ONE, V, LDV, DWORK(PDW6), N ) END IF END IF C C 15) DW1 := B2'*W2 C IF ( M.GT.K ) THEN IF ( LTRB.AND.LCOLW ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, $ B(1,K+1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), $ N ) ELSE IF ( LTRB ) THEN C C Critical Position C CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, $ B(1,K+1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), $ N ) ELSE IF ( LCOLW ) THEN CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, $ B(K+1,1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), $ N ) ELSE CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ B(K+1,1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), $ N ) END IF ELSE IF ( .NOT.LA1B1 ) THEN CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) END IF C C 16) DW6 := B2'*V2 C IF ( M.GT.K ) THEN IF ( LTRB.AND.LCOLV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, $ B(1,K+1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), $ N ) ELSE IF ( LTRB ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, $ B(1,K+1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), $ N ) ELSE IF ( LCOLV ) THEN CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, $ B(K+1,1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), $ N ) ELSE CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ B(K+1,1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), $ N ) END IF ELSE IF ( .NOT.LA1B1 ) THEN CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW6), N ) END IF C IF ( LTRQ ) THEN C C 17) DW7 := DW1*R1 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW7), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PR1), LDRS, DWORK(PDW7), N ) C C 18) DW8 := DW6*R3 C CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) C C 19) DW7 := DW7 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7+N), 1 ) C IF ( LA1B1 ) THEN C C NZ15) DW8 := DW9*R2 C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, RS(1,PR2), LDRS, DWORK(PDW8), N ) C C NZ16) DW7 := DW7 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) END IF C C 20) DW8 := DW7*S1 C CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) C C 21) DW3 := DW3 - DW8 C CALL DAXPY( N*(K-1), -ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) C C 22) DW8 := DW7*S3 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, RS(1,PS3), LDRS, DWORK(PDW8), N ) C C 23) DW5 := DW5 - DW8 C CALL DAXPY( N*K, -ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) C C 24) DW7 := DW7*S2 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ -ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) ELSE C C 17) DW7 := DW6*S3' C CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW7), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS3), LDRS, DWORK(PDW7), N ) C C 18) DW8 := DW1*S1' C CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) C C 19) DW7 := DW7 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) C IF ( LA1B1 ) THEN C C NZ15) DW8 := DW9*S2' C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS2), LDRS, DWORK(PDW8), N ) C C NZ16) DW7 := DW7 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) END IF C C 20) DW8 := DW7*R1' C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PR1), LDRS, DWORK(PDW8), N ) C C 21) DW3 := DW3 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) C C 22) DW8 := DW7*R3' C CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) C C 23) DW5 := DW5 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) C C 24) DW7 := DW7*R2' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) END IF C C 25) A2 := A2 + W2*DW3' C IF ( M.GT.K ) THEN IF ( LTRA.AND.LCOLW ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, A(1,K+1), $ LDA ) ELSE IF ( LTRA ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, A(1,K+1), $ LDA ) ELSE IF ( LCOLW ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), $ LDA ) ELSE CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), $ LDA ) END IF END IF C C 26) A2 := A2 + V2*DW5' C IF ( M.GT.K ) THEN IF ( LTRA.AND.LCOLV ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, $ DWORK(PDW5), N, V(K+1,1), LDV, ONE, A(1,K+1), $ LDA ) ELSE IF ( LTRA ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, $ DWORK(PDW5), N, V(1,K+1), LDV, ONE, A(1,K+1), $ LDA ) ELSE IF ( LCOLV ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, $ V(K+1,1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), $ LDA ) ELSE CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, $ V(1,K+1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), $ LDA ) END IF END IF C C 27) DW4 := DW4 + DW7 C CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW4), 1 ) C C 28) DW3 := DW3*W1' C IF ( LCOLW ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, $ W, LDW, DWORK(PDW3), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, W, LDW, DWORK(PDW3), N ) END IF C C 29) DW4 := DW4 + DW3 C CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) C C 30) DW5 := DW5*V1' C IF ( LCOLV ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, $ V, LDV, DWORK(PDW5), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, V, LDV, DWORK(PDW5), N ) END IF C C 31) DW4 := DW4 + DW5 C CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C C 32) A1 := A1 + DW4' C IF ( LA1B1 ) THEN IF ( LTRA ) THEN DO 50 I = 1, K CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) 50 CONTINUE ELSE DO 60 I = 1, N CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, A(1,I), 1 ) 60 CONTINUE END IF ELSE IF ( LTRA ) THEN DO 70 I = 1, K CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) 70 CONTINUE ELSE DO 80 I = 1, N CALL DCOPY( K, DWORK(PDW4+I-1), N, A(1,I), 1 ) 80 CONTINUE END IF END IF C C Update the matrix B. C IF ( LTRQ ) THEN C C 33) DW3 := DW1*T11 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) C C 34) DW4 := DW6*T31 C CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) C C 35) DW3 := DW3 + DW4 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) C IF ( LA1B1 ) THEN C C NZ17) DW8 := DW9*T21 C CALL DCOPY( N*(K-1), DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) C C NZ18) DW3 := DW3 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) END IF C C 36) DW4 := DW2*S1 C CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW4), N ) C C 37) DW3 := DW3 + DW4 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) C C 38) DW4 := DW1*T12 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT12), LDT, DWORK(PDW4), N ) C C 38) DW5 := DW6*T32 C CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) C C 40) DW4 := DW4 + DW5 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) C IF ( LA1B1 ) THEN C C NZ19) DW8 := DW9*T22 C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) C C NZ20) DW4 := DW4 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) END IF C C 41) DW5 := DW2*S2 C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS2), LDRS, DWORK(PDW5), N ) C C 42) DW4 := DW4 + DW5 C CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C C 43) DW6 := DW6*T33 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) C C 44) DW1 := DW1*T13 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT13), LDT, DWORK(PDW1), N ) C C 45) DW6 := DW6 + DW1 C CALL DAXPY( N*K, ONE, DWORK(PDW1), 1, DWORK(PDW6), 1 ) C IF ( LA1B1 ) THEN C C NZ19) DW9 := DW9*T23 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT23), LDT, DWORK(PDW9), N ) C C NZ20) DW6 := DW6 + DW9 C CALL DAXPY( N*K, ONE, DWORK(PDW9), 1, DWORK(PDW6), 1 ) END IF C C 46) DW2 := DW2*S3 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) C C 45) DW6 := DW6 + DW2 C CALL DAXPY( N*K, ONE, DWORK(PDW2), 1, DWORK(PDW6), 1 ) ELSE C C 33) DW3 := DW1*T11' C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) C C 34) DW4 := DW6*T13' C CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) C C 35) DW3 := DW3 + DW4 C CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) C IF ( LA1B1 ) THEN C C NZ17) DW8 := DW9*T12' C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) C C NZ18) DW3 := DW3 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) END IF C C 36) DW4 := DW2*R1' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PR1), LDRS, DWORK(PDW4), N ) C C 37) DW3 := DW3 - DW4 C CALL DAXPY( N*K, -ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) C C 38) DW4 := DW6*T23' C CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) C C 39) DW5 := DW1*T21' C CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) C C 40) DW4 := DW4 + DW5 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C IF ( LA1B1 ) THEN C C NZ19) DW8 := DW9*T22' C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) C C NZ20) DW4 := DW4 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) END IF C C 41) DW5 := DW2*R2' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, RS(1,PR2), LDRS, DWORK(PDW5), N ) C C 42) DW4 := DW4 - DW5 C CALL DAXPY( N*K, -ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C C 43) DW6 := DW6*T33' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) C C 44) DW1 := DW1*T31' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, T(1,PT31+1), LDT, DWORK(PDW1+N), N ) C C 45) DW6 := DW6 + DW1 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) C IF ( LA1B1 ) THEN C C NZ19) DW9 := DW9*T32' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW9+N), N ) C C NZ20) DW6 := DW6 + DW9 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW9+N), 1, DWORK(PDW6), 1 ) END IF C C 46) DW2 := DW2*R3' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW2+N), N ) C C 45) DW6 := DW6 - DW2 C CALL DAXPY( N*(K-1), -ONE, DWORK(PDW2+N), 1, DWORK(PDW6), 1 ) END IF C C 46) B2 := B2 + W2*DW3' C IF ( M.GT.K ) THEN IF ( LTRB.AND.LCOLW ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, B(1,K+1), $ LDB ) ELSE IF ( LTRB ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, B(1,K+1), $ LDB ) ELSE IF ( LCOLW ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), $ LDB ) ELSE CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), $ LDB ) END IF END IF C C 47) B2 := B2 + V2*DW6' C IF ( M.GT.K ) THEN IF ( LTRB.AND.LCOLV ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, $ DWORK(PDW6), N, V(K+1,1), LDV, ONE, B(1,K+1), $ LDB ) ELSE IF ( LTRB ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, $ DWORK(PDW6), N, V(1,K+1), LDV, ONE, B(1,K+1), $ LDB ) ELSE IF ( LCOLV ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, $ V(K+1,1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), $ LDB ) ELSE CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, $ V(1,K+1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), $ LDB ) END IF END IF C C 48) DW3 := DW3*W1' C IF ( LCOLW ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, $ W, LDW, DWORK(PDW3), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, W, LDW, DWORK(PDW3), N ) END IF C C 49) DW4 := DW4 + DW3 C CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) C C 50) DW6 := DW6*V1' C IF ( LCOLV ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, $ V, LDV, DWORK(PDW6), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, V, LDV, DWORK(PDW6), N ) END IF C C 51) DW4 := DW4 + DW6 C CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW4), 1 ) C C 52) B1 := B1 + DW4' C IF ( LA1B1 ) THEN IF ( LTRB ) THEN DO 90 I = 1, K CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) 90 CONTINUE ELSE DO 100 I = 1, N CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, B(1,I), 1 ) 100 CONTINUE END IF ELSE IF ( LTRB ) THEN DO 110 I = 1, K CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) 110 CONTINUE ELSE DO 120 I = 1, N CALL DCOPY( K, DWORK(PDW4+I-1), N, B(1,I), 1 ) 120 CONTINUE END IF END IF C RETURN C *** Last line of MB04QC *** END