SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * OCTOBER 31, 1992 * * .. SCALAR ARGUMENTS .. DOUBLE PRECISION A, B, C, RT1, RT2 * .. * * PURPOSE * ======= * * DLAE2 COMPUTES THE EIGENVALUES OF A 2-BY-2 SYMMETRIC MATRIX * [ A B ] * [ B C ]. * ON RETURN, RT1 IS THE EIGENVALUE OF LARGER ABSOLUTE VALUE, AND RT2 * IS THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. * * ARGUMENTS * ========= * * A (INPUT) DOUBLE PRECISION * THE (1,1) ENTRY OF THE 2-BY-2 MATRIX. * * B (INPUT) DOUBLE PRECISION * THE (1,2) AND (2,1) ENTRIES OF THE 2-BY-2 MATRIX. * * C (INPUT) DOUBLE PRECISION * THE (2,2) ENTRY OF THE 2-BY-2 MATRIX. * * RT1 (OUTPUT) DOUBLE PRECISION * THE EIGENVALUE OF LARGER ABSOLUTE VALUE. * * RT2 (OUTPUT) DOUBLE PRECISION * THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. * * FURTHER DETAILS * =============== * * RT1 IS ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. * * RT2 MAY BE INACCURATE IF THERE IS MASSIVE CANCELLATION IN THE * DETERMINANT A*C-B*B; HIGHER PRECISION OR CORRECTLY ROUNDED OR * CORRECTLY TRUNCATED ARITHMETIC WOULD BE NEEDED TO COMPUTE RT2 * ACCURATELY IN ALL CASES. * * OVERFLOW IS POSSIBLE ONLY IF RT1 IS WITHIN A FACTOR OF 5 OF OVERFLOW. * UNDERFLOW IS HARMLESS IF THE INPUT DATA IS 0 OR EXCEEDS * UNDERFLOW_THRESHOLD / MACHEPS. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. LOCAL SCALARS .. DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS, SQRT * .. * .. EXECUTABLE STATEMENTS .. * * COMPUTE THE EIGENVALUES * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * INCLUDES CASE AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) * * ORDER OF EXECUTION IMPORTANT. * TO GET FULLY ACCURATE SMALLER EIGENVALUE, * NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) * * ORDER OF EXECUTION IMPORTANT. * TO GET FULLY ACCURATE SMALLER EIGENVALUE, * NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * INCLUDES CASE RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT END IF RETURN * * END OF DLAE2 * END SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * OCTOBER 31, 1992 * * .. SCALAR ARGUMENTS .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 * .. * * PURPOSE * ======= * * DLAEV2 COMPUTES THE EIGENDECOMPOSITION OF A 2-BY-2 SYMMETRIC MATRIX * [ A B ] * [ B C ]. * ON RETURN, RT1 IS THE EIGENVALUE OF LARGER ABSOLUTE VALUE, RT2 IS THE * EIGENVALUE OF SMALLER ABSOLUTE VALUE, AND (CS1,SN1) IS THE UNIT RIGHT * EIGENVECTOR FOR RT1, GIVING THE DECOMPOSITION * * [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] * [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. * * ARGUMENTS * ========= * * A (INPUT) DOUBLE PRECISION * THE (1,1) ENTRY OF THE 2-BY-2 MATRIX. * * B (INPUT) DOUBLE PRECISION * THE (1,2) ENTRY AND THE CONJUGATE OF THE (2,1) ENTRY OF THE * 2-BY-2 MATRIX. * * C (INPUT) DOUBLE PRECISION * THE (2,2) ENTRY OF THE 2-BY-2 MATRIX. * * RT1 (OUTPUT) DOUBLE PRECISION * THE EIGENVALUE OF LARGER ABSOLUTE VALUE. * * RT2 (OUTPUT) DOUBLE PRECISION * THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. * * CS1 (OUTPUT) DOUBLE PRECISION * SN1 (OUTPUT) DOUBLE PRECISION * THE VECTOR (CS1, SN1) IS A UNIT RIGHT EIGENVECTOR FOR RT1. * * FURTHER DETAILS * =============== * * RT1 IS ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. * * RT2 MAY BE INACCURATE IF THERE IS MASSIVE CANCELLATION IN THE * DETERMINANT A*C-B*B; HIGHER PRECISION OR CORRECTLY ROUNDED OR * CORRECTLY TRUNCATED ARITHMETIC WOULD BE NEEDED TO COMPUTE RT2 * ACCURATELY IN ALL CASES. * * CS1 AND SN1 ARE ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. * * OVERFLOW IS POSSIBLE ONLY IF RT1 IS WITHIN A FACTOR OF 5 OF OVERFLOW. * UNDERFLOW IS HARMLESS IF THE INPUT DATA IS 0 OR EXCEEDS * UNDERFLOW_THRESHOLD / MACHEPS. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. LOCAL SCALARS .. INTEGER SGN1, SGN2 DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, $ TB, TN * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS, SQRT * .. * .. EXECUTABLE STATEMENTS .. * * COMPUTE THE EIGENVALUES * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * INCLUDES CASE AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) SGN1 = -1 * * ORDER OF EXECUTION IMPORTANT. * TO GET FULLY ACCURATE SMALLER EIGENVALUE, * NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) SGN1 = 1 * * ORDER OF EXECUTION IMPORTANT. * TO GET FULLY ACCURATE SMALLER EIGENVALUE, * NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * INCLUDES CASE RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT SGN1 = 1 END IF * * COMPUTE THE EIGENVECTOR * IF( DF.GE.ZERO ) THEN CS = DF + RT SGN2 = 1 ELSE CS = DF - RT SGN2 = -1 END IF ACS = ABS( CS ) IF( ACS.GT.AB ) THEN CT = -TB / CS SN1 = ONE / SQRT( ONE+CT*CT ) CS1 = CT*SN1 ELSE IF( AB.EQ.ZERO ) THEN CS1 = ONE SN1 = ZERO ELSE TN = -CS / TB CS1 = ONE / SQRT( ONE+TN*TN ) SN1 = TN*CS1 END IF END IF IF( SGN1.EQ.SGN2 ) THEN TN = CS1 CS1 = -SN1 SN1 = TN END IF RETURN * * END OF DLAEV2 * END DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * OCTOBER 31, 1992 * * .. SCALAR ARGUMENTS .. CHARACTER NORM, UPLO INTEGER N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION AP( * ), WORK( * ) * .. * * PURPOSE * ======= * * DLANSP RETURNS THE VALUE OF THE ONE NORM, OR THE FROBENIUS NORM, OR * THE INFINITY NORM, OR THE ELEMENT OF LARGEST ABSOLUTE VALUE OF A * REAL SYMMETRIC MATRIX A, SUPPLIED IN PACKED FORM. * * DESCRIPTION * =========== * * DLANSP RETURNS THE VALUE * * DLANSP = ( MAX(ABS(A(I,J))), NORM = 'M' OR 'M' * ( * ( NORM1(A), NORM = '1', 'O' OR 'O' * ( * ( NORMI(A), NORM = 'I' OR 'I' * ( * ( NORMF(A), NORM = 'F', 'F', 'E' OR 'E' * * WHERE NORM1 DENOTES THE ONE NORM OF A MATRIX (MAXIMUM COLUMN SUM), * NORMI DENOTES THE INFINITY NORM OF A MATRIX (MAXIMUM ROW SUM) AND * NORMF DENOTES THE FROBENIUS NORM OF A MATRIX (SQUARE ROOT OF SUM OF * SQUARES). NOTE THAT MAX(ABS(A(I,J))) IS NOT A MATRIX NORM. * * ARGUMENTS * ========= * * NORM (INPUT) CHARACTER*1 * SPECIFIES THE VALUE TO BE RETURNED IN DLANSP AS DESCRIBED * ABOVE. * * UPLO (INPUT) CHARACTER*1 * SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE * SYMMETRIC MATRIX A IS SUPPLIED. * = 'U': UPPER TRIANGULAR PART OF A IS SUPPLIED * = 'L': LOWER TRIANGULAR PART OF A IS SUPPLIED * * N (INPUT) INTEGER * THE ORDER OF THE MATRIX A. N >= 0. WHEN N = 0, DLANSP IS * SET TO ZERO. * * AP (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N*(N+1)/2) * THE UPPER OR LOWER TRIANGLE OF THE SYMMETRIC MATRIX A, PACKED * COLUMNWISE IN A LINEAR ARRAY. THE J-TH COLUMN OF A IS STORED * IN THE ARRAY AP AS FOLLOWS: * IF UPLO = 'U', AP(I + (J-1)*J/2) = A(I,J) FOR 1<=I<=J; * IF UPLO = 'L', AP(I + (J-1)*(2N-J)/2) = A(I,J) FOR J<=I<=N. * * WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK), * WHERE LWORK >= N WHEN NORM = 'I' OR '1' OR 'O'; OTHERWISE, * WORK IS NOT REFERENCED. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. LOCAL SCALARS .. INTEGER I, J, K DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DLASSQ * .. * .. EXTERNAL FUNCTIONS .. LOGICAL LSAME EXTERNAL LSAME * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS, MAX, SQRT * .. * .. EXECUTABLE STATEMENTS .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * FIND MAX(ABS(A(I,J))). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN K = 1 DO 20 J = 1, N DO 10 I = K, K + J - 1 VALUE = MAX( VALUE, ABS( AP( I ) ) ) 10 CONTINUE K = K + J 20 CONTINUE ELSE K = 1 DO 40 J = 1, N DO 30 I = K, K + N - J VALUE = MAX( VALUE, ABS( AP( I ) ) ) 30 CONTINUE K = K + N - J + 1 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * FIND NORMI(A) ( = NORM1(A), SINCE A IS SYMMETRIC). * VALUE = ZERO K = 1 IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 50 CONTINUE WORK( J ) = SUM + ABS( AP( K ) ) K = K + 1 60 CONTINUE DO 70 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( AP( K ) ) K = K + 1 DO 90 I = J + 1, N ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 90 CONTINUE VALUE = MAX( VALUE, SUM ) 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * FIND NORMF(A). * SCALE = ZERO SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF SUM = 2*SUM K = 1 DO 130 I = 1, N IF( AP( K ).NE.ZERO ) THEN ABSA = ABS( AP( K ) ) IF( SCALE.LT.ABSA ) THEN SUM = ONE + SUM*( SCALE / ABSA )**2 SCALE = ABSA ELSE SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN K = K + I + 1 ELSE K = K + N - I + 1 END IF 130 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANSP = VALUE RETURN * * END OF DLANSP * END DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * OCTOBER 31, 1992 * * .. SCALAR ARGUMENTS .. DOUBLE PRECISION X, Y * .. * * PURPOSE * ======= * * DLAPY2 RETURNS SQRT(X**2+Y**2), TAKING CARE NOT TO CAUSE UNNECESSARY * OVERFLOW. * * ARGUMENTS * ========= * * X (INPUT) DOUBLE PRECISION * Y (INPUT) DOUBLE PRECISION * X AND Y SPECIFY THE VALUES X AND Y. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. LOCAL SCALARS .. DOUBLE PRECISION W, XABS, YABS, Z * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. EXECUTABLE STATEMENTS .. * XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN DLAPY2 = W ELSE DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF RETURN * * END OF DLAPY2 * END SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * FEBRUARY 29, 1992 * * .. SCALAR ARGUMENTS .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * PURPOSE * ======= * * DLARF APPLIES A REAL ELEMENTARY REFLECTOR H TO A REAL M BY N MATRIX * C, FROM EITHER THE LEFT OR THE RIGHT. H IS REPRESENTED IN THE FORM * * H = I - TAU * V * V' * * WHERE TAU IS A REAL SCALAR AND V IS A REAL VECTOR. * * IF TAU = 0, THEN H IS TAKEN TO BE THE UNIT MATRIX. * * ARGUMENTS * ========= * * SIDE (INPUT) CHARACTER*1 * = 'L': FORM H * C * = 'R': FORM C * H * * M (INPUT) INTEGER * THE NUMBER OF ROWS OF THE MATRIX C. * * N (INPUT) INTEGER * THE NUMBER OF COLUMNS OF THE MATRIX C. * * V (INPUT) DOUBLE PRECISION ARRAY, DIMENSION * (1 + (M-1)*ABS(INCV)) IF SIDE = 'L' * OR (1 + (N-1)*ABS(INCV)) IF SIDE = 'R' * THE VECTOR V IN THE REPRESENTATION OF H. V IS NOT USED IF * TAU = 0. * * INCV (INPUT) INTEGER * THE INCREMENT BETWEEN ELEMENTS OF V. INCV <> 0. * * TAU (INPUT) DOUBLE PRECISION * THE VALUE TAU IN THE REPRESENTATION OF H. * * C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N) * ON ENTRY, THE M BY N MATRIX C. * ON EXIT, C IS OVERWRITTEN BY THE MATRIX H * C IF SIDE = 'L', * OR C * H IF SIDE = 'R'. * * LDC (INPUT) INTEGER * THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M). * * WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION * (N) IF SIDE = 'L' * OR (M) IF SIDE = 'R' * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DGEMV, DGER * .. * .. EXTERNAL FUNCTIONS .. LOGICAL LSAME EXTERNAL LSAME * .. * .. EXECUTABLE STATEMENTS .. * IF( LSAME( SIDE, 'L' ) ) THEN * * FORM H * C * IF( TAU.NE.ZERO ) THEN * * W := C' * V * CALL DGEMV( 'TRANSPOSE', M, N, ONE, C, LDC, V, INCV, ZERO, $ WORK, 1 ) * * C := C - V * W' * CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * FORM C * H * IF( TAU.NE.ZERO ) THEN * * W := C * V * CALL DGEMV( 'NO TRANSPOSE', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - W * V' * CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * END OF DLARF * END SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * FEBRUARY 29, 1992 * * .. SCALAR ARGUMENTS .. INTEGER INCX, N DOUBLE PRECISION ALPHA, TAU * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION X( * ) * .. * * PURPOSE * ======= * * DLARFG GENERATES A REAL ELEMENTARY REFLECTOR H OF ORDER N, SUCH * THAT * * H * ( ALPHA ) = ( BETA ), H' * H = I. * ( X ) ( 0 ) * * WHERE ALPHA AND BETA ARE SCALARS, AND X IS AN (N-1)-ELEMENT REAL * VECTOR. H IS REPRESENTED IN THE FORM * * H = I - TAU * ( 1 ) * ( 1 V' ) , * ( V ) * * WHERE TAU IS A REAL SCALAR AND V IS A REAL (N-1)-ELEMENT * VECTOR. * * IF THE ELEMENTS OF X ARE ALL ZERO, THEN TAU = 0 AND H IS TAKEN TO BE * THE UNIT MATRIX. * * OTHERWISE 1 <= TAU <= 2. * * ARGUMENTS * ========= * * N (INPUT) INTEGER * THE ORDER OF THE ELEMENTARY REFLECTOR. * * ALPHA (INPUT/OUTPUT) DOUBLE PRECISION * ON ENTRY, THE VALUE ALPHA. * ON EXIT, IT IS OVERWRITTEN WITH THE VALUE BETA. * * X (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION * (1+(N-2)*ABS(INCX)) * ON ENTRY, THE VECTOR X. * ON EXIT, IT IS OVERWRITTEN WITH THE VECTOR V. * * INCX (INPUT) INTEGER * THE INCREMENT BETWEEN ELEMENTS OF X. INCX <> 0. * * TAU (OUTPUT) DOUBLE PRECISION * THE VALUE TAU. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. LOCAL SCALARS .. INTEGER J, KNT DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM * .. * .. EXTERNAL FUNCTIONS .. DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2 * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS, SIGN * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DSCAL * .. * .. EXECUTABLE STATEMENTS .. * IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF * XNORM = DNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * GENERAL CASE * BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA MAY BE INACCURATE; SCALE X AND RECOMPUTE THEM * RSAFMN = ONE / SAFMIN KNT = 0 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * NEW BETA IS AT MOST 1, AT LEAST SAFMIN * XNORM = DNRM2( N-1, X, INCX ) BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * IF ALPHA IS SUBNORMAL, IT MAY LOSE RELATIVE ACCURACY * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) ALPHA = BETA END IF END IF * RETURN * * END OF DLARFG * END SUBROUTINE DLARTG( F, G, CS, SN, R ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * OCTOBER 31, 1992 * * .. SCALAR ARGUMENTS .. DOUBLE PRECISION CS, F, G, R, SN * .. * * PURPOSE * ======= * * DLARTG GENERATE A PLANE ROTATION SO THAT * * [ CS SN ] . [ F ] = [ R ] WHERE CS**2 + SN**2 = 1. * [ -SN CS ] [ G ] [ 0 ] * * THIS IS A FASTER VERSION OF THE BLAS1 ROUTINE DROTG, EXCEPT FOR * THE FOLLOWING DIFFERENCES: * F AND G ARE UNCHANGED ON RETURN. * IF G=0, THEN CS=1 AND SN=0. * IF F=0 AND (G .NE. 0), THEN CS=0 AND SN=1 WITHOUT DOING ANY * FLOATING POINT OPERATIONS (SAVES WORK IN DBDSQR WHEN * THERE ARE ZEROS ON THE DIAGONAL). * * ARGUMENTS * ========= * * F (INPUT) DOUBLE PRECISION * THE FIRST COMPONENT OF VECTOR TO BE ROTATED. * * G (INPUT) DOUBLE PRECISION * THE SECOND COMPONENT OF VECTOR TO BE ROTATED. * * CS (OUTPUT) DOUBLE PRECISION * THE COSINE OF THE ROTATION. * * SN (OUTPUT) DOUBLE PRECISION * THE SINE OF THE ROTATION. * * R (OUTPUT) DOUBLE PRECISION * THE NONZERO COMPONENT OF THE ROTATED VECTOR. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. LOCAL SCALARS .. DOUBLE PRECISION T, TT * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS, SQRT * .. * .. EXECUTABLE STATEMENTS .. * IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = ONE R = G ELSE IF( ABS( F ).GT.ABS( G ) ) THEN T = G / F TT = SQRT( ONE+T*T ) CS = ONE / TT SN = T*CS R = F*TT ELSE T = F / G TT = SQRT( ONE+T*T ) SN = ONE / TT CS = T*SN R = G*TT END IF END IF RETURN * * END OF DLARTG * END SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * OCTOBER 31, 1992 * * .. SCALAR ARGUMENTS .. CHARACTER DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) * .. * * PURPOSE * ======= * * DLASR PERFORMS THE TRANSFORMATION * * A := P*A, WHEN SIDE = 'L' OR 'L' ( LEFT-HAND SIDE ) * * A := A*P', WHEN SIDE = 'R' OR 'R' ( RIGHT-HAND SIDE ) * * WHERE A IS AN M BY N REAL MATRIX AND P IS AN ORTHOGONAL MATRIX, * CONSISTING OF A SEQUENCE OF PLANE ROTATIONS DETERMINED BY THE * PARAMETERS PIVOT AND DIRECT AS FOLLOWS ( Z = M WHEN SIDE = 'L' OR 'L' * AND Z = N WHEN SIDE = 'R' OR 'R' ): * * WHEN DIRECT = 'F' OR 'F' ( FORWARD SEQUENCE ) THEN * * P = P( Z - 1 )*...*P( 2 )*P( 1 ), * * AND WHEN DIRECT = 'B' OR 'B' ( BACKWARD SEQUENCE ) THEN * * P = P( 1 )*P( 2 )*...*P( Z - 1 ), * * WHERE P( K ) IS A PLANE ROTATION MATRIX FOR THE FOLLOWING PLANES: * * WHEN PIVOT = 'V' OR 'V' ( VARIABLE PIVOT ), * THE PLANE ( K, K + 1 ) * * WHEN PIVOT = 'T' OR 'T' ( TOP PIVOT ), * THE PLANE ( 1, K + 1 ) * * WHEN PIVOT = 'B' OR 'B' ( BOTTOM PIVOT ), * THE PLANE ( K, Z ) * * C( K ) AND S( K ) MUST CONTAIN THE COSINE AND SINE THAT DEFINE THE * MATRIX P( K ). THE TWO BY TWO PLANE ROTATION PART OF THE MATRIX * P( K ), R( K ), IS ASSUMED TO BE OF THE FORM * * R( K ) = ( C( K ) S( K ) ). * ( -S( K ) C( K ) ) * * THIS VERSION VECTORISES ACROSS ROWS OF THE ARRAY A WHEN SIDE = 'L'. * * ARGUMENTS * ========= * * SIDE (INPUT) CHARACTER*1 * SPECIFIES WHETHER THE PLANE ROTATION MATRIX P IS APPLIED TO * A ON THE LEFT OR THE RIGHT. * = 'L': LEFT, COMPUTE A := P*A * = 'R': RIGHT, COMPUTE A:= A*P' * * DIRECT (INPUT) CHARACTER*1 * SPECIFIES WHETHER P IS A FORWARD OR BACKWARD SEQUENCE OF * PLANE ROTATIONS. * = 'F': FORWARD, P = P( Z - 1 )*...*P( 2 )*P( 1 ) * = 'B': BACKWARD, P = P( 1 )*P( 2 )*...*P( Z - 1 ) * * PIVOT (INPUT) CHARACTER*1 * SPECIFIES THE PLANE FOR WHICH P(K) IS A PLANE ROTATION * MATRIX. * = 'V': VARIABLE PIVOT, THE PLANE (K,K+1) * = 'T': TOP PIVOT, THE PLANE (1,K+1) * = 'B': BOTTOM PIVOT, THE PLANE (K,Z) * * M (INPUT) INTEGER * THE NUMBER OF ROWS OF THE MATRIX A. IF M <= 1, AN IMMEDIATE * RETURN IS EFFECTED. * * N (INPUT) INTEGER * THE NUMBER OF COLUMNS OF THE MATRIX A. IF N <= 1, AN * IMMEDIATE RETURN IS EFFECTED. * * C, S (INPUT) DOUBLE PRECISION ARRAYS, DIMENSION * (M-1) IF SIDE = 'L' * (N-1) IF SIDE = 'R' * C(K) AND S(K) CONTAIN THE COSINE AND SINE THAT DEFINE THE * MATRIX P(K). THE TWO BY TWO PLANE ROTATION PART OF THE * MATRIX P(K), R(K), IS ASSUMED TO BE OF THE FORM * R( K ) = ( C( K ) S( K ) ). * ( -S( K ) C( K ) ) * * A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) * THE M BY N MATRIX A. ON EXIT, A IS OVERWRITTEN BY P*A IF * SIDE = 'R' OR BY A*P' IF SIDE = 'L'. * * LDA (INPUT) INTEGER * THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. LOCAL SCALARS .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP, TEMP * .. * .. EXTERNAL FUNCTIONS .. LOGICAL LSAME EXTERNAL LSAME * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL XERBLA * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC MAX * .. * .. EXECUTABLE STATEMENTS .. * * TEST THE INPUT PARAMETERS * INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASR ', INFO ) RETURN END IF * * QUICK RETURN IF POSSIBLE * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * FORM P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * FORM A * P' * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * END OF DLASR * END SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * OCTOBER 31, 1992 * * .. SCALAR ARGUMENTS .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION X( * ) * .. * * PURPOSE * ======= * * DLASSQ RETURNS THE VALUES SCL AND SMSQ SUCH THAT * * ( SCL**2 )*SMSQ = X( 1 )**2 +...+ X( N )**2 + ( SCALE**2 )*SUMSQ, * * WHERE X( I ) = X( 1 + ( I - 1 )*INCX ). THE VALUE OF SUMSQ IS * ASSUMED TO BE NON-NEGATIVE AND SCL RETURNS THE VALUE * * SCL = MAX( SCALE, ABS( X( I ) ) ). * * SCALE AND SUMSQ MUST BE SUPPLIED IN SCALE AND SUMSQ AND * SCL AND SMSQ ARE OVERWRITTEN ON SCALE AND SUMSQ RESPECTIVELY. * * THE ROUTINE MAKES ONLY ONE PASS THROUGH THE VECTOR X. * * ARGUMENTS * ========= * * N (INPUT) INTEGER * THE NUMBER OF ELEMENTS TO BE USED FROM THE VECTOR X. * * X (INPUT) DOUBLE PRECISION * THE VECTOR FOR WHICH A SCALED SUM OF SQUARES IS COMPUTED. * X( I ) = X( 1 + ( I - 1 )*INCX ), 1 <= I <= N. * * INCX (INPUT) INTEGER * THE INCREMENT BETWEEN SUCCESSIVE VALUES OF THE VECTOR X. * INCX > 0. * * SCALE (INPUT/OUTPUT) DOUBLE PRECISION * ON ENTRY, THE VALUE SCALE IN THE EQUATION ABOVE. * ON EXIT, SCALE IS OVERWRITTEN WITH SCL , THE SCALING FACTOR * FOR THE SUM OF SQUARES. * * SUMSQ (INPUT/OUTPUT) DOUBLE PRECISION * ON ENTRY, THE VALUE SUMSQ IN THE EQUATION ABOVE. * ON EXIT, SUMSQ IS OVERWRITTEN WITH SMSQ , THE BASIC SUM OF * SQUARES FROM WHICH SCL HAS BEEN FACTORED OUT. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. LOCAL SCALARS .. INTEGER IX DOUBLE PRECISION ABSXI * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS * .. * .. EXECUTABLE STATEMENTS .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( X( IX ).NE.ZERO ) THEN ABSXI = ABS( X( IX ) ) IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN * * END OF DLASSQ * END SUBROUTINE DLAZRO( M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * OCTOBER 31, 1992 * * .. SCALAR ARGUMENTS .. INTEGER LDA, M, N DOUBLE PRECISION ALPHA, BETA * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION A( LDA, * ) * .. * * PURPOSE * ======= * * DLAZRO INITIALIZES A 2-D ARRAY A TO BETA ON THE DIAGONAL AND * ALPHA ON THE OFFDIAGONALS. * * ARGUMENTS * ========= * * M (INPUT) INTEGER * THE NUMBER OF ROWS OF THE MATRIX A. M >= 0. * * N (INPUT) INTEGER * THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0. * * ALPHA (INPUT) DOUBLE PRECISION * THE CONSTANT TO WHICH THE OFFDIAGONAL ELEMENTS ARE TO BE SET. * * BETA (INPUT) DOUBLE PRECISION * THE CONSTANT TO WHICH THE DIAGONAL ELEMENTS ARE TO BE SET. * * A (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) * ON EXIT, THE LEADING M BY N SUBMATRIX OF A IS SET SUCH THAT * A(I,J) = ALPHA, 1 <= I <= M, 1 <= J <= N, I <> J * A(I,I) = BETA, 1 <= I <= MIN(M,N). * * LDA (INPUT) INTEGER * THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). * * ===================================================================== * * .. LOCAL SCALARS .. INTEGER I, J * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC MIN * .. * .. EXECUTABLE STATEMENTS .. * DO 20 J = 1, N DO 10 I = 1, M A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE * DO 30 I = 1, MIN( M, N ) A( I, I ) = BETA 30 CONTINUE * RETURN * * END OF DLAZRO * END SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * * -- LAPACK ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * MARCH 31, 1993 * * .. SCALAR ARGUMENTS .. CHARACTER UPLO INTEGER INFO, LDQ, N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) * .. * * PURPOSE * ======= * * DOPGTR GENERATES A REAL ORTHOGONAL MATRIX Q WHICH IS DEFINED AS THE * PRODUCT OF N-1 ELEMENTARY REFLECTORS OF ORDER N, AS RETURNED BY * DSPTRD USING PACKED STORAGE: * * IF UPLO = 'U', Q = H(N-1) . . . H(2) H(1), * * IF UPLO = 'L', Q = H(1) H(2) . . . H(N-1). * * ARGUMENTS * ========= * * UPLO (INPUT) CHARACTER*1 * = 'U': UPPER TRIANGULAR PACKED STORAGE USED IN PREVIOUS * CALL TO DSPTRD; * = 'L': LOWER TRIANGULAR PACKED STORAGE USED IN PREVIOUS * CALL TO DSPTRD. * * N (INPUT) INTEGER * THE ORDER OF THE MATRIX Q. N >= 0. * * AP (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N*(N+1)/2) * THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS, AS * RETURNED BY DSPTRD. * * TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) * TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY * REFLECTOR H(I), AS RETURNED BY DSPTRD. * * Q (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDQ,N) * THE N-BY-N ORTHOGONAL MATRIX Q. * * LDQ (INPUT) INTEGER * THE LEADING DIMENSION OF THE ARRAY Q. LDQ >= MAX(1,N). * * WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N-1) * * INFO (OUTPUT) INTEGER * = 0: SUCCESSFUL EXIT * < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. LOCAL SCALARS .. LOGICAL UPPER INTEGER I, IINFO, IJ, J * .. * .. EXTERNAL FUNCTIONS .. LOGICAL LSAME EXTERNAL LSAME * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DORG2L, DORG2R, XERBLA * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC MAX * .. * .. EXECUTABLE STATEMENTS .. * * TEST THE INPUT ARGUMENTS * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DOPGTR', -INFO ) RETURN END IF * * QUICK RETURN IF POSSIBLE * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Q WAS DETERMINED BY A CALL TO DSPTRD WITH UPLO = 'U' * * UNPACK THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS AND * SET THE LAST ROW AND COLUMN OF Q EQUAL TO THOSE OF THE UNIT * MATRIX * IJ = 2 DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 Q( I, J ) = AP( IJ ) IJ = IJ + 1 10 CONTINUE IJ = IJ + 2 Q( N, J ) = ZERO 20 CONTINUE DO 30 I = 1, N - 1 Q( I, N ) = ZERO 30 CONTINUE Q( N, N ) = ONE * * GENERATE Q(1:N-1,1:N-1) * CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) * ELSE * * Q WAS DETERMINED BY A CALL TO DSPTRD WITH UPLO = 'L'. * * UNPACK THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS AND * SET THE FIRST ROW AND COLUMN OF Q EQUAL TO THOSE OF THE UNIT * MATRIX * Q( 1, 1 ) = ONE DO 40 I = 2, N Q( I, 1 ) = ZERO 40 CONTINUE IJ = 3 DO 60 J = 2, N Q( 1, J ) = ZERO DO 50 I = J + 1, N Q( I, J ) = AP( IJ ) IJ = IJ + 1 50 CONTINUE IJ = IJ + 2 60 CONTINUE IF( N.GT.1 ) THEN * * GENERATE Q(2:N,2:N) * CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, $ IINFO ) END IF END IF RETURN * * END OF DOPGTR * END SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * FEBRUARY 29, 1992 * * .. SCALAR ARGUMENTS .. INTEGER INFO, K, LDA, M, N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * PURPOSE * ======= * * DORG2L GENERATES AN M BY N REAL MATRIX Q WITH ORTHONORMAL COLUMNS, * WHICH IS DEFINED AS THE LAST N COLUMNS OF A PRODUCT OF K ELEMENTARY * REFLECTORS OF ORDER M * * Q = H(K) . . . H(2) H(1) * * AS RETURNED BY DGEQLF. * * ARGUMENTS * ========= * * M (INPUT) INTEGER * THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0. * * N (INPUT) INTEGER * THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0. * * K (INPUT) INTEGER * THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE * MATRIX Q. N >= K >= 0. * * A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) * ON ENTRY, THE (N-K+I)-TH COLUMN MUST CONTAIN THE VECTOR WHICH * DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS * RETURNED BY DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY * ARGUMENT A. * ON EXIT, THE M BY N MATRIX Q. * * LDA (INPUT) INTEGER * THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). * * TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) * TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY * REFLECTOR H(I), AS RETURNED BY DGEQLF. * * WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N) * * INFO (OUTPUT) INTEGER * = 0: SUCCESSFUL EXIT * < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. LOCAL SCALARS .. INTEGER I, II, J, L * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC MAX * .. * .. EXECUTABLE STATEMENTS .. * * TEST THE INPUT ARGUMENTS * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2L', -INFO ) RETURN END IF * * QUICK RETURN IF POSSIBLE * IF( N.LE.0 ) $ RETURN * * INITIALISE COLUMNS 1:N-K TO COLUMNS OF THE UNIT MATRIX * DO 20 J = 1, N - K DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( M-N+J, J ) = ONE 20 CONTINUE * DO 40 I = 1, K II = N - K + I * * APPLY H(I) TO A(1:M-K+I,1:N-K+I) FROM THE LEFT * A( M-N+II, II ) = ONE CALL DLARF( 'LEFT', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, $ LDA, WORK ) CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * * SET A(M-K+I+1:M,N-K+I) TO ZERO * DO 30 L = M - N + II + 1, M A( L, II ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * END OF DORG2L * END SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * FEBRUARY 29, 1992 * * .. SCALAR ARGUMENTS .. INTEGER INFO, K, LDA, M, N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * PURPOSE * ======= * * DORG2R GENERATES AN M BY N REAL MATRIX Q WITH ORTHONORMAL COLUMNS, * WHICH IS DEFINED AS THE FIRST N COLUMNS OF A PRODUCT OF K ELEMENTARY * REFLECTORS OF ORDER M * * Q = H(1) H(2) . . . H(K) * * AS RETURNED BY DGEQRF. * * ARGUMENTS * ========= * * M (INPUT) INTEGER * THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0. * * N (INPUT) INTEGER * THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0. * * K (INPUT) INTEGER * THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE * MATRIX Q. N >= K >= 0. * * A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) * ON ENTRY, THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH * DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS * RETURNED BY DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY * ARGUMENT A. * ON EXIT, THE M-BY-N MATRIX Q. * * LDA (INPUT) INTEGER * THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). * * TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) * TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY * REFLECTOR H(I), AS RETURNED BY DGEQRF. * * WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N) * * INFO (OUTPUT) INTEGER * = 0: SUCCESSFUL EXIT * < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. LOCAL SCALARS .. INTEGER I, J, L * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DLARF, DSCAL, XERBLA * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC MAX * .. * .. EXECUTABLE STATEMENTS .. * * TEST THE INPUT ARGUMENTS * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2R', -INFO ) RETURN END IF * * QUICK RETURN IF POSSIBLE * IF( N.LE.0 ) $ RETURN * * INITIALISE COLUMNS K+1:N TO COLUMNS OF THE UNIT MATRIX * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * APPLY H(I) TO A(I:M,I:N) FROM THE LEFT * IF( I.LT.N ) THEN A( I, I ) = ONE CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * SET A(1:I-1,I) TO ZERO * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * END OF DORG2R * END SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) * * -- LAPACK DRIVER ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * MARCH 31, 1993 * * .. SCALAR ARGUMENTS .. CHARACTER JOBZ, UPLO INTEGER INFO, LDZ, N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * PURPOSE * ======= * * DSPEV COMPUTES ALL THE EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A * REAL SYMMETRIC MATRIX A IN PACKED STORAGE. * * ARGUMENTS * ========= * * JOBZ (INPUT) CHARACTER*1 * = 'N': COMPUTE EIGENVALUES ONLY; * = 'V': COMPUTE EIGENVALUES AND EIGENVECTORS. * * UPLO (INPUT) CHARACTER*1 * = 'U': UPPER TRIANGLE OF A IS STORED; * = 'L': LOWER TRIANGLE OF A IS STORED. * * N (INPUT) INTEGER * THE ORDER OF THE MATRIX A. N >= 0. * * AP (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N*(N+1)/2) * ON ENTRY, THE UPPER OR LOWER TRIANGLE OF THE SYMMETRIC MATRIX * A, PACKED COLUMNWISE IN A LINEAR ARRAY. THE J-TH COLUMN OF A * IS STORED IN THE ARRAY AP AS FOLLOWS: * IF UPLO = 'U', AP(I + (J-1)*J/2) = A(I,J) FOR 1<=I<=J; * IF UPLO = 'L', AP(I + (J-1)*(2*N-J)/2) = A(I,J) FOR J<=I<=N. * * ON EXIT, AP IS OVERWRITTEN BY VALUES GENERATED DURING THE * REDUCTION TO TRIDIAGONAL FORM. IF UPLO = 'U', THE DIAGONAL * AND FIRST SUPERDIAGONAL OF THE TRIDIAGONAL MATRIX T OVERWRITE * THE CORRESPONDING ELEMENTS OF A, AND IF UPLO = 'L', THE * DIAGONAL AND FIRST SUBDIAGONAL OF T OVERWRITE THE * CORRESPONDING ELEMENTS OF A. * * W (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) * IF INFO = 0, THE EIGENVALUES IN ASCENDING ORDER. * * Z (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, N) * IF JOBZ = 'V', THEN IF INFO = 0, Z CONTAINS THE ORTHONORMAL * EIGENVECTORS OF THE MATRIX A, WITH THE I-TH COLUMN OF Z * HOLDING THE EIGENVECTOR ASSOCIATED WITH W(I). * IF JOBZ = 'N', THEN Z IS NOT REFERENCED. * * LDZ (INPUT) INTEGER * THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= 1, AND IF * JOBZ = 'V', LDZ >= MAX(1,N). * * WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (3*N) * * INFO (OUTPUT) INTEGER * = 0: SUCCESSFUL EXIT. * < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE. * > 0: IF INFO = I, THE ALGORITHM FAILED TO CONVERGE; I * OFF-DIAGONAL ELEMENTS OF AN INTERMEDIATE TRIDIAGONAL * FORM DID NOT CONVERGE TO ZERO. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. LOCAL SCALARS .. LOGICAL WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. EXTERNAL FUNCTIONS .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSP EXTERNAL LSAME, DLAMCH, DLANSP * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC SQRT * .. * .. EXECUTABLE STATEMENTS .. * * TEST THE INPUT PARAMETERS. * WANTZ = LSAME( JOBZ, 'V' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) $ THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPEV ', -INFO ) RETURN END IF * * QUICK RETURN IF POSSIBLE * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = AP( 1 ) IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * GET MACHINE CONSTANTS. * SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'P' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * SCALE MATRIX TO ALLOWABLE RANGE, IF NECESSARY. * ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) END IF * * CALL DSPTRD TO REDUCE SYMMETRIC PACKED MATRIX TO TRIDIAGONAL FORM. * INDE = 1 INDTAU = INDE + N CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) * * FOR EIGENVALUES ONLY, CALL DSTERF. FOR EIGENVECTORS, FIRST CALL * DOPGTR TO GENERATE THE ORTHOGONAL MATRIX, THEN CALL DSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE INDWRK = INDTAU + N CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, $ WORK( INDWRK ), IINFO ) CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ), $ INFO ) END IF * * IF MATRIX WAS SCALED, THEN RESCALE EIGENVALUES APPROPRIATELY. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * RETURN * * END OF DSPEV * END SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) * * -- LAPACK ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * MARCH 31, 1993 * * .. SCALAR ARGUMENTS .. CHARACTER UPLO INTEGER INFO, N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) * .. * * PURPOSE * ======= * * DSPTRD REDUCES A REAL SYMMETRIC MATRIX A STORED IN PACKED FORM TO * SYMMETRIC TRIDIAGONAL FORM T BY AN ORTHOGONAL SIMILARITY * TRANSFORMATION: Q**T * A * Q = T. * * ARGUMENTS * ========= * * UPLO (INPUT) CHARACTER*1 * = 'U': UPPER TRIANGLE OF A IS STORED; * = 'L': LOWER TRIANGLE OF A IS STORED. * * N (INPUT) INTEGER * THE ORDER OF THE MATRIX A. N >= 0. * * AP (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N*(N+1)/2) * ON ENTRY, THE UPPER OR LOWER TRIANGLE OF THE SYMMETRIC MATRIX * A, PACKED COLUMNWISE IN A LINEAR ARRAY. THE J-TH COLUMN OF A * IS STORED IN THE ARRAY AP AS FOLLOWS: * IF UPLO = 'U', AP(I + (J-1)*J/2) = A(I,J) FOR 1<=I<=J; * IF UPLO = 'L', AP(I + (J-1)*(2*N-J)/2) = A(I,J) FOR J<=I<=N. * ON EXIT, IF UPLO = 'U', THE DIAGONAL AND FIRST SUPERDIAGONAL * OF A ARE OVERWRITTEN BY THE CORRESPONDING ELEMENTS OF THE * TRIDIAGONAL MATRIX T, AND THE ELEMENTS ABOVE THE FIRST * SUPERDIAGONAL, WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL * MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS; IF UPLO * = 'L', THE DIAGONAL AND FIRST SUBDIAGONAL OF A ARE OVER- * WRITTEN BY THE CORRESPONDING ELEMENTS OF THE TRIDIAGONAL * MATRIX T, AND THE ELEMENTS BELOW THE FIRST SUBDIAGONAL, WITH * THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A PRODUCT * OF ELEMENTARY REFLECTORS. SEE FURTHER DETAILS. * * D (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) * THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T: * D(I) = A(I,I). * * E (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) * THE OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T: * E(I) = A(I,I+1) IF UPLO = 'U', E(I) = A(I+1,I) IF UPLO = 'L'. * * TAU (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) * THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS (SEE FURTHER * DETAILS). * * INFO (OUTPUT) INTEGER * = 0: SUCCESSFUL EXIT * < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE * * FURTHER DETAILS * =============== * * IF UPLO = 'U', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY * REFLECTORS * * Q = H(N-1) . . . H(2) H(1). * * EACH H(I) HAS THE FORM * * H(I) = I - TAU * V * V' * * WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH * V(I+1:N) = 0 AND V(I) = 1; V(1:I-1) IS STORED ON EXIT IN AP, * OVERWRITING A(1:I-1,I+1), AND TAU IS STORED IN TAU(I). * * IF UPLO = 'L', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY * REFLECTORS * * Q = H(1) H(2) . . . H(N-1). * * EACH H(I) HAS THE FORM * * H(I) = I - TAU * V * V' * * WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH * V(1:I) = 0 AND V(I+1) = 1; V(I+2:N) IS STORED ON EXIT IN AP, * OVERWRITING A(I+2:N,I), AND TAU IS STORED IN TAU(I). * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ONE, ZERO, HALF PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, $ HALF = 1.0D0 / 2.0D0 ) * .. * .. LOCAL SCALARS .. LOGICAL UPPER INTEGER I, I1, I1I1, II DOUBLE PRECISION ALPHA, TAUI * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA * .. * .. EXTERNAL FUNCTIONS .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. EXECUTABLE STATEMENTS .. * * TEST THE INPUT PARAMETERS * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRD', -INFO ) RETURN END IF * * QUICK RETURN IF POSSIBLE * IF( N.LE.0 ) $ RETURN * IF( UPPER ) THEN * * REDUCE THE UPPER TRIANGLE OF A. * I1 IS THE INDEX IN AP OF A(1,I+1). * I1 = N*( N-1 ) / 2 + 1 DO 10 I = N - 1, 1, -1 * * GENERATE ELEMENTARY REFLECTOR H(I) = I - TAU * V * V' * TO ANNIHILATE A(1:I-1,I+1) * CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI ) E( I ) = AP( I1+I-1 ) * IF( TAUI.NE.ZERO ) THEN * * APPLY H(I) FROM BOTH SIDES TO A(1:I,1:I) * AP( I1+I-1 ) = ONE * * COMPUTE Y := TAU * A * V STORING Y IN TAU(1:I) * CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, $ 1 ) * * COMPUTE W := Y - 1/2 * TAU * (Y'*V) * V * ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 ) CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) * * APPLY THE TRANSFORMATION AS A RANK-2 UPDATE: * A := A - V * W' - W * V' * CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) * AP( I1+I-1 ) = E( I ) END IF D( I+1 ) = AP( I1+I ) TAU( I ) = TAUI I1 = I1 - I 10 CONTINUE D( 1 ) = AP( 1 ) ELSE * * REDUCE THE LOWER TRIANGLE OF A. II IS THE INDEX IN AP OF * A(I,I) AND I1I1 IS THE INDEX OF A(I+1,I+1). * II = 1 DO 20 I = 1, N - 1 I1I1 = II + N - I + 1 * * GENERATE ELEMENTARY REFLECTOR H(I) = I - TAU * V * V' * TO ANNIHILATE A(I+2:N,I) * CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI ) E( I ) = AP( II+1 ) * IF( TAUI.NE.ZERO ) THEN * * APPLY H(I) FROM BOTH SIDES TO A(I+1:N,I+1:N) * AP( II+1 ) = ONE * * COMPUTE Y := TAU * A * V STORING Y IN TAU(I:N-1) * CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, $ ZERO, TAU( I ), 1 ) * * COMPUTE W := Y - 1/2 * TAU * (Y'*V) * V * ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ), $ 1 ) CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) * * APPLY THE TRANSFORMATION AS A RANK-2 UPDATE: * A := A - V * W' - W * V' * CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, $ AP( I1I1 ) ) * AP( II+1 ) = E( I ) END IF D( I ) = AP( II ) TAU( I ) = TAUI II = I1I1 20 CONTINUE D( N ) = AP( II ) END IF * RETURN * * END OF DSPTRD * END SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * -- LAPACK ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * MARCH 31, 1993 * * .. SCALAR ARGUMENTS .. CHARACTER COMPZ INTEGER INFO, LDZ, N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * PURPOSE * ======= * * DSTEQR COMPUTES ALL EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A * SYMMETRIC TRIDIAGONAL MATRIX USING THE IMPLICIT QL OR QR METHOD. * THE EIGENVECTORS OF A FULL OR BAND SYMMETRIC MATRIX CAN ALSO BE FOUND * IF DSYTRD OR DSPTRD OR DSBTRD HAS BEEN USED TO REDUCE THIS MATRIX TO * TRIDIAGONAL FORM. * * ARGUMENTS * ========= * * COMPZ (INPUT) CHARACTER*1 * = 'N': COMPUTE EIGENVALUES ONLY. * = 'V': COMPUTE EIGENVALUES AND EIGENVECTORS OF THE ORIGINAL * SYMMETRIC MATRIX. ON ENTRY, Z MUST CONTAIN THE * ORTHOGONAL MATRIX USED TO REDUCE THE ORIGINAL MATRIX * TO TRIDIAGONAL FORM. * = 'I': COMPUTE EIGENVALUES AND EIGENVECTORS OF THE * TRIDIAGONAL MATRIX. Z IS INITIALIZED TO THE IDENTITY * MATRIX. * * N (INPUT) INTEGER * THE ORDER OF THE MATRIX. N >= 0. * * D (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) * ON ENTRY, THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. * ON EXIT, IF INFO = 0, THE EIGENVALUES IN ASCENDING ORDER. * * E (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) * ON ENTRY, THE (N-1) SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL * MATRIX. * ON EXIT, E HAS BEEN DESTROYED. * * Z (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, N) * ON ENTRY, IF COMPZ = 'V', THEN Z CONTAINS THE ORTHOGONAL * MATRIX USED IN THE REDUCTION TO TRIDIAGONAL FORM. * ON EXIT, IF COMPZ = 'V', Z CONTAINS THE ORTHONORMAL * EIGENVECTORS OF THE ORIGINAL SYMMETRIC MATRIX, AND IF * COMPZ = 'I', Z CONTAINS THE ORTHONORMAL EIGENVECTORS OF * THE SYMMETRIC TRIDIAGONAL MATRIX. IF AN ERROR EXIT IS * MADE, Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE * STORED EIGENVALUES. * IF COMPZ = 'N', THEN Z IS NOT REFERENCED. * * LDZ (INPUT) INTEGER * THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= 1, AND IF * EIGENVECTORS ARE DESIRED, THEN LDZ >= MAX(1,N). * * WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (MAX(1,2*N-2)) * IF COMPZ = 'N', THEN WORK IS NOT REFERENCED. * * INFO (OUTPUT) INTEGER * = 0: SUCCESSFUL EXIT * < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE * > 0: THE ALGORITHM HAS FAILED TO FIND ALL THE EIGENVALUES IN * A TOTAL OF 30*N ITERATIONS; IF INFO = I, THEN I * ELEMENTS OF E HAVE NOT CONVERGED TO ZERO; ON EXIT, D * AND E CONTAIN THE ELEMENTS OF A SYMMETRIC TRIDIAGONAL * MATRIX WHICH IS ORTHOGONALLY SIMILAR TO THE ORIGINAL * MATRIX. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. LOCAL SCALARS .. INTEGER I, ICOMPZ, II, J, JTOT, K, L, L1, LEND, LENDM1, $ LENDP1, LM1, M, MM, MM1, NM1, NMAXIT DOUBLE PRECISION B, C, EPS, F, G, P, R, RT1, RT2, S, TST * .. * .. EXTERNAL FUNCTIONS .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL LSAME, DLAMCH, DLAPY2 * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DLAE2, DLAEV2, DLARTG, DLASR, DLAZRO, DSWAP, $ XERBLA * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS, MAX, SIGN * .. * .. EXECUTABLE STATEMENTS .. * * TEST THE INPUT PARAMETERS. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEQR', -INFO ) RETURN END IF * * QUICK RETURN IF POSSIBLE * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.GT.0 ) $ Z( 1, 1 ) = ONE RETURN END IF * * DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT. * EPS = DLAMCH( 'E' ) * * COMPUTE THE EIGENVALUES AND EIGENVECTORS OF THE TRIDIAGONAL * MATRIX. * IF( ICOMPZ.EQ.2 ) $ CALL DLAZRO( N, N, ZERO, ONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * DETERMINE WHERE THE MATRIX SPLITS AND CHOOSE QL OR QR ITERATION * FOR EACH BLOCK, ACCORDING TO WHETHER TOP OR BOTTOM DIAGONAL * ELEMENT IS SMALLER. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) $ GO TO 30 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LEND = M IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN L = LEND LEND = L1 END IF L1 = M + 1 * IF( LEND.GE.L ) THEN * * QL ITERATION * * LOOK FOR SMALL SUBDIAGONAL ELEMENT. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) $ GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * IF REMAINING MATRIX IS 2-BY-2, USE DLAE2 OR DLAEV2 * TO COMPUTE ITS EIGENSYSTEM. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 10 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * FORM SHIFT. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * INNER LOOP * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * IF EIGENVECTORS ARE DESIRED, THEN SAVE ROTATIONS. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * IF EIGENVECTORS ARE DESIRED, THEN APPLY SAVED ROTATIONS. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * EIGENVALUE FOUND. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 10 * ELSE * * QR ITERATION * * LOOK FOR SMALL SUPERDIAGONAL ELEMENT. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) ) $ GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * IF REMAINING MATRIX IS 2-BY-2, USE DLAE2 OR DLAEV2 * TO COMPUTE ITS EIGENSYSTEM. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 10 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * FORM SHIFT. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * INNER LOOP * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * IF EIGENVECTORS ARE DESIRED, THEN SAVE ROTATIONS. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * IF EIGENVECTORS ARE DESIRED, THEN APPLY SAVED ROTATIONS. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * EIGENVALUE FOUND. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 10 * END IF * * SET ERROR -- NO CONVERGENCE TO AN EIGENVALUE AFTER A TOTAL * OF N*MAXIT ITERATIONS. * 140 CONTINUE DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE RETURN * * ORDER EIGENVALUES AND EIGENVECTORS. * 160 CONTINUE DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P IF( ICOMPZ.GT.0 ) $ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE * RETURN * * END OF DSTEQR * END SUBROUTINE DSTERF( N, D, E, INFO ) * * -- LAPACK ROUTINE (VERSION 1.1) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * MARCH 31, 1993 * * .. SCALAR ARGUMENTS .. INTEGER INFO, N * .. * .. ARRAY ARGUMENTS .. DOUBLE PRECISION D( * ), E( * ) * .. * * PURPOSE * ======= * * DSTERF COMPUTES ALL EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX * USING THE PAL-WALKER-KAHAN VARIANT OF THE QL OR QR ALGORITHM. * * ARGUMENTS * ========= * * N (INPUT) INTEGER * THE ORDER OF THE MATRIX. N >= 0. * * D (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) * ON ENTRY, THE N DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. * ON EXIT, IF INFO = 0, THE EIGENVALUES IN ASCENDING ORDER. * * E (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) * ON ENTRY, THE (N-1) SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL * MATRIX. * ON EXIT, E HAS BEEN DESTROYED. * * INFO (OUTPUT) INTEGER * = 0: SUCCESSFUL EXIT * < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE * > 0: THE ALGORITHM FAILED TO FIND ALL OF THE EIGENVALUES IN * A TOTAL OF 30*N ITERATIONS; IF INFO = I, THEN I * ELEMENTS OF E HAVE NOT CONVERGED TO ZERO. * * ===================================================================== * * .. PARAMETERS .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. LOCAL SCALARS .. INTEGER I, II, J, JTOT, K, L, L1, LEND, LENDM1, LENDP1, $ LM1, M, MM1, NM1, NMAXIT DOUBLE PRECISION ALPHA, BB, C, EPS, GAMMA, OLDC, OLDGAM, P, R, $ RT1, RT2, RTE, S, SIGMA, TST * .. * .. EXTERNAL FUNCTIONS .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. EXTERNAL SUBROUTINES .. EXTERNAL DLAE2, XERBLA * .. * .. INTRINSIC FUNCTIONS .. INTRINSIC ABS, SIGN, SQRT * .. * .. EXECUTABLE STATEMENTS .. * * TEST THE INPUT PARAMETERS. * INFO = 0 * * QUICK RETURN IF POSSIBLE * IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DSTERF', -INFO ) RETURN END IF IF( N.LE.1 ) $ RETURN * * DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT. * EPS = DLAMCH( 'E' ) * * COMPUTE THE EIGENVALUES OF THE TRIDIAGONAL MATRIX. * DO 10 I = 1, N - 1 E( I ) = E( I )**2 10 CONTINUE * NMAXIT = N*MAXIT SIGMA = ZERO JTOT = 0 * * DETERMINE WHERE THE MATRIX SPLITS AND CHOOSE QL OR QR ITERATION * FOR EACH BLOCK, ACCORDING TO WHETHER TOP OR BOTTOM DIAGONAL * ELEMENT IS SMALLER. * L1 = 1 NM1 = N - 1 * 20 CONTINUE IF( L1.GT.N ) $ GO TO 170 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 30 M = L1, NM1 TST = SQRT( ABS( E( M ) ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) $ GO TO 40 30 CONTINUE END IF M = N * 40 CONTINUE L = L1 LEND = M IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN L = LEND LEND = L1 END IF L1 = M + 1 * IF( LEND.GE.L ) THEN * * QL ITERATION * * LOOK FOR SMALL SUBDIAGONAL ELEMENT. * 50 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 60 M = L, LENDM1 TST = SQRT( ABS( E( M ) ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) $ GO TO 70 60 CONTINUE END IF * M = LEND * 70 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 90 * * IF REMAINING MATRIX IS 2 BY 2, USE DLAE2 TO COMPUTE ITS * EIGENVALUES. * IF( M.EQ.L+1 ) THEN RTE = SQRT( E( L ) ) CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 50 GO TO 20 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 150 JTOT = JTOT + 1 * * FORM SHIFT. * RTE = SQRT( E( L ) ) SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) R = DLAPY2( SIGMA, ONE ) SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) * C = ONE S = ZERO GAMMA = D( M ) - SIGMA P = GAMMA*GAMMA * * INNER LOOP * MM1 = M - 1 DO 80 I = MM1, L, -1 BB = E( I ) R = P + BB IF( I.NE.M-1 ) $ E( I+1 ) = S*R OLDC = C C = P / R S = BB / R OLDGAM = GAMMA ALPHA = D( I ) GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) IF( C.NE.ZERO ) THEN P = ( GAMMA*GAMMA ) / C ELSE P = OLDC*BB END IF 80 CONTINUE * E( L ) = S*P D( L ) = SIGMA + GAMMA GO TO 50 * * EIGENVALUE FOUND. * 90 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 50 GO TO 20 * ELSE * * QR ITERATION * * LOOK FOR SMALL SUPERDIAGONAL ELEMENT. * 100 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 110 M = L, LENDP1, -1 TST = SQRT( ABS( E( M-1 ) ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) ) $ GO TO 120 110 CONTINUE END IF * M = LEND * 120 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 140 * * IF REMAINING MATRIX IS 2 BY 2, USE DLAE2 TO COMPUTE ITS * EIGENVALUES. * IF( M.EQ.L-1 ) THEN RTE = SQRT( E( L-1 ) ) CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) D( L ) = RT1 D( L-1 ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 100 GO TO 20 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 150 JTOT = JTOT + 1 * * FORM SHIFT. * RTE = SQRT( E( L-1 ) ) SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) R = DLAPY2( SIGMA, ONE ) SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) * C = ONE S = ZERO GAMMA = D( M ) - SIGMA P = GAMMA*GAMMA * * INNER LOOP * LM1 = L - 1 DO 130 I = M, LM1 BB = E( I ) R = P + BB IF( I.NE.M ) $ E( I-1 ) = S*R OLDC = C C = P / R S = BB / R OLDGAM = GAMMA ALPHA = D( I+1 ) GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM D( I ) = OLDGAM + ( ALPHA-GAMMA ) IF( C.NE.ZERO ) THEN P = ( GAMMA*GAMMA ) / C ELSE P = OLDC*BB END IF 130 CONTINUE * E( LM1 ) = S*P D( L ) = SIGMA + GAMMA GO TO 100 * * EIGENVALUE FOUND. * 140 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 100 GO TO 20 * END IF * * SET ERROR -- NO CONVERGENCE TO AN EIGENVALUE AFTER A TOTAL * OF N*MAXIT ITERATIONS. * 150 CONTINUE DO 160 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 160 CONTINUE RETURN * * SORT EIGENVALUES IN INCREASING ORDER. * 170 CONTINUE DO 190 II = 2, N I = II - 1 K = I P = D( I ) DO 180 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 180 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P END IF 190 CONTINUE * RETURN * * END OF DSTERF * END LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK AUXILIARY ROUTINE (VERSION 1.0) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * FEBRUARY 29, 1992 * * .. SCALAR ARGUMENTS .. CHARACTER CA, CB * .. * * PURPOSE * ======= * * LSAME RETURNS .TRUE. IF CA IS THE SAME LETTER AS CB REGARDLESS OF * CASE. * * ARGUMENTS * ========= * * CA (INPUT) CHARACTER*1 * CB (INPUT) CHARACTER*1 * CA AND CB SPECIFY THE SINGLE CHARACTERS TO BE COMPARED. * * .. INTRINSIC FUNCTIONS .. INTRINSIC ICHAR * .. * .. LOCAL SCALARS .. INTEGER INTA, INTB, ZCODE * .. * .. EXECUTABLE STATEMENTS .. * * TEST IF THE CHARACTERS ARE EQUAL * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * NOW TEST FOR EQUIVALENCE IF BOTH CHARACTERS ARE ALPHABETIC. * ZCODE = ICHAR( 'Z' ) * * USE 'Z' RATHER THAN 'A' SO THAT ASCII CAN BE DETECTED ON PRIME * MACHINES, ON WHICH ICHAR RETURNS A VALUE WITH BIT 8 SET. * ICHAR('A') ON PRIME MACHINES RETURNS 193 WHICH IS THE SAME AS * ICHAR('A') ON AN EBCDIC MACHINE. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII IS ASSUMED - ZCODE IS THE ASCII CODE OF EITHER LOWER OR * UPPER CASE 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC IS ASSUMED - ZCODE IS THE EBCDIC CODE OF EITHER LOWER OR * UPPER CASE 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII IS ASSUMED, ON PRIME MACHINES - ZCODE IS THE ASCII CODE * PLUS 128 OF EITHER LOWER OR UPPER CASE 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * END OF LSAME * END SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK AUXILIARY ROUTINE (PRELIMINARY VERSION) -- * UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., * COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY * FEBRUARY 29, 1992 * * .. SCALAR ARGUMENTS .. CHARACTER*6 SRNAME INTEGER INFO * .. * * PURPOSE * ======= * * XERBLA IS AN ERROR HANDLER FOR THE LAPACK ROUTINES. * IT IS CALLED BY AN LAPACK ROUTINE IF AN INPUT PARAMETER HAS AN * INVALID VALUE. A MESSAGE IS PRINTED AND EXECUTION STOPS. * * INSTALLERS MAY CONSIDER MODIFYING THE STOP STATEMENT IN ORDER TO * CALL SYSTEM-SPECIFIC EXCEPTION-HANDLING FACILITIES. * * ARGUMENTS * ========= * * SRNAME (INPUT) CHARACTER*6 * THE NAME OF THE ROUTINE WHICH CALLED XERBLA. * * INFO (INPUT) INTEGER * THE POSITION OF THE INVALID PARAMETER IN THE PARAMETER LIST * OF THE CALLING ROUTINE. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** ON ENTRY TO ', A6, ' PARAMETER NUMBER ', I2, ' HAD ', $ 'AN ILLEGAL VALUE' ) * * END OF XERBLA * END DOUBLE COMPLEX FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY) C C FORMS THE DOT PRODUCT OF A VECTOR. C JACK DONGARRA, 3/11/78. C DOUBLE COMPLEX ZX(1),ZY(1),ZTEMP INTEGER I,INCX,INCY,IX,IY,N ZTEMP = (0.0D0,0.0D0) ZDOTC = (0.0D0,0.0D0) IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N ZTEMP = ZTEMP + DCONJG(ZX(IX))*ZY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE ZDOTC = ZTEMP RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N ZTEMP = ZTEMP + DCONJG(ZX(I))*ZY(I) 30 CONTINUE ZDOTC = ZTEMP RETURN END SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, $ INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ), W( * ) COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a * complex Hermitian matrix in packed storage. * * Arguments * ========= * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) * On entry, the upper or lower triangle of the Hermitian matrix * A, packed columnwise in a linear array. The j-th column of A * is stored in the array AP as follows: * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. * * On exit, AP is overwritten by values generated during the * reduction to tridiagonal form. If UPLO = 'U', the diagonal * and first superdiagonal of the tridiagonal matrix T overwrite * the corresponding elements of A, and if UPLO = 'L', the * diagonal and first subdiagonal of T overwrite the * corresponding elements of A. * * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * * Z (output) COMPLEX*16 array, dimension (LDZ, N) * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal * eigenvectors of the matrix A, with the i-th column of Z * holding the eigenvector associated with W(i). * If JOBZ = 'N', then Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * JOBZ = 'V', LDZ >= max(1,N). * * WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1)) * * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * > 0: if INFO = i, the algorithm failed to converge; i * off-diagonal elements of an intermediate tridiagonal * form did not converge to zero. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL WANTZ INTEGER IINFO, IMAX, INDE, INDRWK, INDTAU, INDWRK, $ ISCALE DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANHP EXTERNAL LSAME, DLAMCH, ZLANHP * .. * .. External Subroutines .. EXTERNAL DSCAL, DSTERF, XERBLA, ZDSCAL, ZHPTRD, ZSTEQR, $ ZUPGTR * .. * .. Intrinsic Functions .. INTRINSIC SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) $ THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHPEV ', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN W( 1 ) = AP( 1 ) RWORK( 1 ) = 1 IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = ZLANHP( 'M', UPLO, N, AP, RWORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) END IF * * Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. * INDE = 1 INDTAU = 1 CALL ZHPTRD( UPLO, N, AP, W, RWORK( INDE ), WORK( INDTAU ), $ IINFO ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * ZUPGTR to generate the orthogonal matrix, then call ZSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, RWORK( INDE ), INFO ) ELSE INDWRK = INDTAU + N CALL ZUPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, $ WORK( INDWRK ), IINFO ) INDRWK = INDE + N CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), Z, LDZ, $ RWORK( INDRWK ), INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * RETURN * * End of ZHPEV * END DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z * .. * * Purpose * ======= * * DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause * unnecessary overflow. * * Arguments * ========= * * X (input) DOUBLE PRECISION * Y (input) DOUBLE PRECISION * Z (input) DOUBLE PRECISION * X, Y and Z specify the values x, y and z. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, ZABS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN DLAPY3 = ZERO ELSE DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) END IF RETURN * * End of DLAPY3 * END SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 AP( * ), B( LDB, * ) * .. * * Purpose * ======= * * ZHPTRS solves a system of linear equations A*X = B with a complex * Hermitian matrix A stored in packed format using the factorization * A = U*D*U**H or A = L*D*L**H computed by ZHPTRF. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the details of the factorization are stored * as an upper or lower triangular matrix. * = 'U': Upper triangular, form is A = U*D*U**H; * = 'L': Lower triangular, form is A = L*D*L**H. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) * The block diagonal matrix D and the multipliers used to * obtain the factor U or L as computed by ZHPTRF, stored as a * packed triangular matrix. * * IPIV (input) INTEGER array, dimension (N) * Details of the interchanges and the block structure of D * as determined by ZHPTRF. * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, K, KC, KP DOUBLE PRECISION S COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZGERU, ZLACGV, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCONJG, MAX * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHPTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Solve A*X = B, where A = U*D*U'. * * First solve U*D*X = B, overwriting B with X. * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N KC = N*( N+1 ) / 2 + 1 10 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 30 * KC = KC - K IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(U(K)), where U(K) is the transformation * stored in column K of A. * CALL ZGERU( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, $ B( 1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * S = DBLE( ONE ) / DBLE( AP( KC+K-1 ) ) CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB ) K = K - 1 ELSE * * 2 x 2 diagonal block * * Interchange rows K-1 and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K-1 ) $ CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(U(K)), where U(K) is the transformation * stored in columns K-1 and K of A. * CALL ZGERU( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, $ B( 1, 1 ), LDB ) CALL ZGERU( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1, $ B( K-1, 1 ), LDB, B( 1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * AKM1K = AP( KC+K-2 ) AKM1 = AP( KC-1 ) / AKM1K AK = AP( KC+K-1 ) / DCONJG( AKM1K ) DENOM = AKM1*AK - ONE DO 20 J = 1, NRHS BKM1 = B( K-1, J ) / AKM1K BK = B( K, J ) / DCONJG( AKM1K ) B( K-1, J ) = ( AK*BKM1-BK ) / DENOM B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 20 CONTINUE KC = KC - K + 1 K = K - 2 END IF * GO TO 10 30 CONTINUE * * Next solve U'*X = B, overwriting B with X. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 KC = 1 40 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 50 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Multiply by inv(U'(K)), where U(K) is the transformation * stored in column K of A. * IF( K.GT.1 ) THEN CALL ZLACGV( NRHS, B( K, 1 ), LDB ) CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, $ LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB ) CALL ZLACGV( NRHS, B( K, 1 ), LDB ) END IF * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC + K K = K + 1 ELSE * * 2 x 2 diagonal block * * Multiply by inv(U'(K+1)), where U(K+1) is the transformation * stored in columns K and K+1 of A. * IF( K.GT.1 ) THEN CALL ZLACGV( NRHS, B( K, 1 ), LDB ) CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, $ LDB, AP( KC ), 1, ONE, B( K, 1 ), LDB ) CALL ZLACGV( NRHS, B( K, 1 ), LDB ) * CALL ZLACGV( NRHS, B( K+1, 1 ), LDB ) CALL ZGEMV( 'Conjugate transpose', K-1, NRHS, -ONE, B, $ LDB, AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB ) CALL ZLACGV( NRHS, B( K+1, 1 ), LDB ) END IF * * Interchange rows K and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K ) $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC + 2*K + 1 K = K + 2 END IF * GO TO 40 50 CONTINUE * ELSE * * Solve A*X = B, where A = L*D*L'. * * First solve L*D*X = B, overwriting B with X. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 KC = 1 60 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 80 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(L(K)), where L(K) is the transformation * stored in column K of A. * IF( K.LT.N ) $ CALL ZGERU( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ), $ LDB, B( K+1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * S = DBLE( ONE ) / DBLE( AP( KC ) ) CALL ZDSCAL( NRHS, S, B( K, 1 ), LDB ) KC = KC + N - K + 1 K = K + 1 ELSE * * 2 x 2 diagonal block * * Interchange rows K+1 and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K+1 ) $ CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(L(K)), where L(K) is the transformation * stored in columns K and K+1 of A. * IF( K.LT.N-1 ) THEN CALL ZGERU( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ), $ LDB, B( K+2, 1 ), LDB ) CALL ZGERU( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1, $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) END IF * * Multiply by the inverse of the diagonal block. * AKM1K = AP( KC+1 ) AKM1 = AP( KC ) / DCONJG( AKM1K ) AK = AP( KC+N-K+1 ) / AKM1K DENOM = AKM1*AK - ONE DO 70 J = 1, NRHS BKM1 = B( K, J ) / DCONJG( AKM1K ) BK = B( K+1, J ) / AKM1K B( K, J ) = ( AK*BKM1-BK ) / DENOM B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 70 CONTINUE KC = KC + 2*( N-K ) + 1 K = K + 2 END IF * GO TO 60 80 CONTINUE * * Next solve L'*X = B, overwriting B with X. * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N KC = N*( N+1 ) / 2 + 1 90 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 100 * KC = KC - ( N-K+1 ) IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Multiply by inv(L'(K)), where L(K) is the transformation * stored in column K of A. * IF( K.LT.N ) THEN CALL ZLACGV( NRHS, B( K, 1 ), LDB ) CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, $ B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE, $ B( K, 1 ), LDB ) CALL ZLACGV( NRHS, B( K, 1 ), LDB ) END IF * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K = K - 1 ELSE * * 2 x 2 diagonal block * * Multiply by inv(L'(K-1)), where L(K-1) is the transformation * stored in columns K-1 and K of A. * IF( K.LT.N ) THEN CALL ZLACGV( NRHS, B( K, 1 ), LDB ) CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, $ B( K+1, 1 ), LDB, AP( KC+1 ), 1, ONE, $ B( K, 1 ), LDB ) CALL ZLACGV( NRHS, B( K, 1 ), LDB ) * CALL ZLACGV( NRHS, B( K-1, 1 ), LDB ) CALL ZGEMV( 'Conjugate transpose', N-K, NRHS, -ONE, $ B( K+1, 1 ), LDB, AP( KC-( N-K ) ), 1, ONE, $ B( K-1, 1 ), LDB ) CALL ZLACGV( NRHS, B( K-1, 1 ), LDB ) END IF * * Interchange rows K and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K ) $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC - ( N-K+2 ) K = K - 2 END IF * GO TO 90 100 CONTINUE END IF * RETURN * * End of ZHPTRS * END SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AP( * ), B( LDB, * ) * .. * * Purpose * ======= * * DSPTRS solves a system of linear equations A*X = B with a real * symmetric matrix A stored in packed format using the factorization * A = U*D*U**T or A = L*D*L**T computed by DSPTRF. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the details of the factorization are stored * as an upper or lower triangular matrix. * = 'U': Upper triangular, form is A = U*D*U**T; * = 'L': Lower triangular, form is A = L*D*L**T. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) * The block diagonal matrix D and the multipliers used to * obtain the factor U or L as computed by DSPTRF, stored as a * packed triangular matrix. * * IPIV (input) INTEGER array, dimension (N) * Details of the interchanges and the block structure of D * as determined by DSPTRF. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, K, KC, KP DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Solve A*X = B, where A = U*D*U'. * * First solve U*D*X = B, overwriting B with X. * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N KC = N*( N+1 ) / 2 + 1 10 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 30 * KC = KC - K IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(U(K)), where U(K) is the transformation * stored in column K of A. * CALL DGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, $ B( 1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * CALL DSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB ) K = K - 1 ELSE * * 2 x 2 diagonal block * * Interchange rows K-1 and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K-1 ) $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(U(K)), where U(K) is the transformation * stored in columns K-1 and K of A. * CALL DGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB, $ B( 1, 1 ), LDB ) CALL DGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1, $ B( K-1, 1 ), LDB, B( 1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * AKM1K = AP( KC+K-2 ) AKM1 = AP( KC-1 ) / AKM1K AK = AP( KC+K-1 ) / AKM1K DENOM = AKM1*AK - ONE DO 20 J = 1, NRHS BKM1 = B( K-1, J ) / AKM1K BK = B( K, J ) / AKM1K B( K-1, J ) = ( AK*BKM1-BK ) / DENOM B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM 20 CONTINUE KC = KC - K + 1 K = K - 2 END IF * GO TO 10 30 CONTINUE * * Next solve U'*X = B, overwriting B with X. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 KC = 1 40 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 50 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Multiply by inv(U'(K)), where U(K) is the transformation * stored in column K of A. * CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), $ 1, ONE, B( K, 1 ), LDB ) * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC + K K = K + 1 ELSE * * 2 x 2 diagonal block * * Multiply by inv(U'(K+1)), where U(K+1) is the transformation * stored in columns K and K+1 of A. * CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ), $ 1, ONE, B( K, 1 ), LDB ) CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, $ AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB ) * * Interchange rows K and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC + 2*K + 1 K = K + 2 END IF * GO TO 40 50 CONTINUE * ELSE * * Solve A*X = B, where A = L*D*L'. * * First solve L*D*X = B, overwriting B with X. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 KC = 1 60 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 80 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(L(K)), where L(K) is the transformation * stored in column K of A. * IF( K.LT.N ) $ CALL DGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ), $ LDB, B( K+1, 1 ), LDB ) * * Multiply by the inverse of the diagonal block. * CALL DSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB ) KC = KC + N - K + 1 K = K + 1 ELSE * * 2 x 2 diagonal block * * Interchange rows K+1 and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K+1 ) $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB ) * * Multiply by inv(L(K)), where L(K) is the transformation * stored in columns K and K+1 of A. * IF( K.LT.N-1 ) THEN CALL DGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ), $ LDB, B( K+2, 1 ), LDB ) CALL DGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1, $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB ) END IF * * Multiply by the inverse of the diagonal block. * AKM1K = AP( KC+1 ) AKM1 = AP( KC ) / AKM1K AK = AP( KC+N-K+1 ) / AKM1K DENOM = AKM1*AK - ONE DO 70 J = 1, NRHS BKM1 = B( K, J ) / AKM1K BK = B( K+1, J ) / AKM1K B( K, J ) = ( AK*BKM1-BK ) / DENOM B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM 70 CONTINUE KC = KC + 2*( N-K ) + 1 K = K + 2 END IF * GO TO 60 80 CONTINUE * * Next solve L'*X = B, overwriting B with X. * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N KC = N*( N+1 ) / 2 + 1 90 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 100 * KC = KC - ( N-K+1 ) IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Multiply by inv(L'(K)), where L(K) is the transformation * stored in column K of A. * IF( K.LT.N ) $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB ) * * Interchange rows K and IPIV(K). * KP = IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) K = K - 1 ELSE * * 2 x 2 diagonal block * * Multiply by inv(L'(K-1)), where L(K-1) is the transformation * stored in columns K-1 and K of A. * IF( K.LT.N ) THEN CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB ) CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ), $ LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ), $ LDB ) END IF * * Interchange rows K and -IPIV(K). * KP = -IPIV( K ) IF( KP.NE.K ) $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB ) KC = KC - ( N-K+2 ) K = K - 2 END IF * GO TO 90 100 CONTINUE END IF * RETURN * * End of DSPTRS * END SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DLASCL multiplies the M by N real matrix A by the real scalar * CTO/CFROM. This is done without over/underflow as long as the final * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that * A may be full, upper triangular, lower triangular, upper Hessenberg, * or banded. * * Arguments * ========= * * TYPE (input) CHARACTER*1 * TYPE indices the storage type of the input matrix. * = 'G': A is a full matrix. * = 'L': A is a lower triangular matrix. * = 'U': A is an upper triangular matrix. * = 'H': A is an upper Hessenberg matrix. * = 'B': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the lower * half stored. * = 'Q': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the upper * half stored. * = 'Z': A is a band matrix with lower bandwidth KL and upper * bandwidth KU. * * KL (input) INTEGER * The lower bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * KU (input) INTEGER * The upper bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * CFROM (input) DOUBLE PRECISION * CTO (input) DOUBLE PRECISION * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed * without over/underflow if the final result CTO*A(I,J)/CFROM * can be represented without over/underflow. CFROM must be * nonzero. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * INFO (output) INTEGER * 0 - successful exit * <0 - if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of DLASCL * END DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * Purpose * ======= * * DLANST returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * real symmetric tridiagonal matrix A. * * Description * =========== * * DLANST returns the value * * DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in DLANST as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, DLANST is * set to zero. * * D (input) DOUBLE PRECISION array, dimension (N) * The diagonal elements of A. * * E (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) sub-diagonal or super-diagonal elements of A. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION ANORM, SCALE, SUM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN ANORM = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 ANORM = MAX( ANORM, ABS( D( I ) ) ) ANORM = MAX( ANORM, ABS( E( I ) ) ) 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. $ LSAME( NORM, 'I' ) ) THEN * * Find norm1(A). * IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), $ ABS( E( N-1 ) )+ABS( D( N ) ) ) DO 20 I = 2, N - 1 ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ $ ABS( E( I-1 ) ) ) 20 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( N.GT.1 ) THEN CALL DLASSQ( N-1, E, 1, SCALE, SUM ) SUM = 2*SUM END IF CALL DLASSQ( N, D, 1, SCALE, SUM ) ANORM = SCALE*SQRT( SUM ) END IF * DLANST = ANORM RETURN * * End of DLANST * END SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N COMPLEX*16 ALPHA, BETA * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASET initializes a 2-D array A to BETA on the diagonal and * ALPHA on the offdiagonals. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be set. * = 'U': Upper triangular part is set. The lower triangle * is unchanged. * = 'L': Lower triangular part is set. The upper triangle * is unchanged. * Otherwise: All of the matrix A is set. * * M (input) INTEGER * On entry, M specifies the number of rows of A. * * N (input) INTEGER * On entry, N specifies the number of columns of A. * * ALPHA (input) COMPLEX*16 * All the offdiagonal array elements are set to ALPHA. * * BETA (input) COMPLEX*16 * All the diagonal array elements are set to BETA. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; * A(i,i) = BETA , 1 <= i <= min(m,n) * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the diagonal to BETA and the strictly upper triangular * part of the array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( N, M ) A( I, I ) = BETA 30 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the diagonal to BETA and the strictly lower triangular * part of the array to ALPHA. * DO 50 J = 1, MIN( M, N ) DO 40 I = J + 1, M A( I, J ) = ALPHA 40 CONTINUE 50 CONTINUE DO 60 I = 1, MIN( N, M ) A( I, I ) = BETA 60 CONTINUE * ELSE * * Set the array to BETA on the diagonal and ALPHA on the * offdiagonal. * DO 80 J = 1, N DO 70 I = 1, M A( I, J ) = ALPHA 70 CONTINUE 80 CONTINUE DO 90 I = 1, MIN( M, N ) A( I, I ) = BETA 90 CONTINUE END IF * RETURN * * End of ZLASET * END SUBROUTINE ZLACGV( N, X, INCX ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLACGV conjugates a complex vector of length N. * * Arguments * ========= * * N (input) INTEGER * The length of the vector X. N >= 0. * * X (input/output) COMPLEX*16 array, dimension * (1+(N-1)*abs(INCX)) * On entry, the vector of length N to be conjugated. * On exit, X is overwritten with conjg(X). * * INCX (input) INTEGER * The spacing between successive elements of X. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IOFF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( INCX.EQ.1 ) THEN DO 10 I = 1, N X( I ) = DCONJG( X( I ) ) 10 CONTINUE ELSE IOFF = 1 IF( INCX.LT.0 ) $ IOFF = 1 - ( N-1 )*INCX DO 20 I = 1, N X( IOFF ) = DCONJG( X( IOFF ) ) IOFF = IOFF + INCX 20 CONTINUE END IF RETURN * * End of ZLACGV * END SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ) COMPLEX*16 Z( LDZ, * ) * .. * * Purpose * ======= * * ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a * symmetric tridiagonal matrix using the implicit QL or QR method. * The eigenvectors of a full or band complex Hermitian matrix can also * be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this * matrix to tridiagonal form. * * Arguments * ========= * * COMPZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only. * = 'V': Compute eigenvalues and eigenvectors of the original * Hermitian matrix. On entry, Z must contain the * unitary matrix used to reduce the original matrix * to tridiagonal form. * = 'I': Compute eigenvalues and eigenvectors of the * tridiagonal matrix. Z is initialized to the identity * matrix. * * N (input) INTEGER * The order of the matrix. N >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the diagonal elements of the tridiagonal matrix. * On exit, if INFO = 0, the eigenvalues in ascending order. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the (n-1) subdiagonal elements of the tridiagonal * matrix. * On exit, E has been destroyed. * * Z (input/output) COMPLEX*16 array, dimension (LDZ, N) * On entry, if COMPZ = 'V', then Z contains the unitary * matrix used in the reduction to tridiagonal form. * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the * orthonormal eigenvectors of the original Hermitian matrix, * and if COMPZ = 'I', Z contains the orthonormal eigenvectors * of the symmetric tridiagonal matrix. * If COMPZ = 'N', then Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * eigenvectors are desired, then LDZ >= max(1,N). * * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) * If COMPZ = 'N', then WORK is not referenced. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: the algorithm has failed to find all the eigenvalues in * a total of 30*N iterations; if INFO = i, then i * elements of E have not converged to zero; on exit, D * and E contain the elements of a symmetric tridiagonal * matrix which is unitarily similar to the original * matrix. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA, $ ZLASET, ZLASR, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = CONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.EQ.NMAXIT ) THEN DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE RETURN END IF GO TO 10 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL DLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF RETURN * * End of ZSTEQR * END SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDQ, N * .. * .. Array Arguments .. COMPLEX*16 AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUPGTR generates a complex unitary matrix Q which is defined as the * product of n-1 elementary reflectors H(i) of order n, as returned by * ZHPTRD using packed storage: * * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), * * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangular packed storage used in previous * call to ZHPTRD; * = 'L': Lower triangular packed storage used in previous * call to ZHPTRD. * * N (input) INTEGER * The order of the matrix Q. N >= 0. * * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) * The vectors which define the elementary reflectors, as * returned by ZHPTRD. * * TAU (input) COMPLEX*16 array, dimension (N-1) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZHPTRD. * * Q (output) COMPLEX*16 array, dimension (LDQ,N) * The N-by-N unitary matrix Q. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= max(1,N). * * WORK (workspace) COMPLEX*16 array, dimension (N-1) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IINFO, IJ, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNG2L, ZUNG2R * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUPGTR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Q was determined by a call to ZHPTRD with UPLO = 'U' * * Unpack the vectors which define the elementary reflectors and * set the last row and column of Q equal to those of the unit * matrix * IJ = 2 DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 Q( I, J ) = AP( IJ ) IJ = IJ + 1 10 CONTINUE IJ = IJ + 2 Q( N, J ) = CZERO 20 CONTINUE DO 30 I = 1, N - 1 Q( I, N ) = CZERO 30 CONTINUE Q( N, N ) = CONE * * Generate Q(1:n-1,1:n-1) * CALL ZUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) * ELSE * * Q was determined by a call to ZHPTRD with UPLO = 'L'. * * Unpack the vectors which define the elementary reflectors and * set the first row and column of Q equal to those of the unit * matrix * Q( 1, 1 ) = CONE DO 40 I = 2, N Q( I, 1 ) = CZERO 40 CONTINUE IJ = 3 DO 60 J = 2, N Q( 1, J ) = CZERO DO 50 I = J + 1, N Q( I, J ) = AP( IJ ) IJ = IJ + 1 50 CONTINUE IJ = IJ + 2 60 CONTINUE IF( N.GT.1 ) THEN * * Generate Q(2:n,2:n) * CALL ZUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, $ IINFO ) END IF END IF RETURN * * End of ZUPGTR * END SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 AP( * ), TAU( * ) * .. * * Purpose * ======= * * ZHPTRD reduces a complex Hermitian matrix A stored in packed form to * real symmetric tridiagonal form T by a unitary similarity * transformation: Q**H * A * Q = T. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) * On entry, the upper or lower triangle of the Hermitian matrix * A, packed columnwise in a linear array. The j-th column of A * is stored in the array AP as follows: * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. * On exit, if UPLO = 'U', the diagonal and first superdiagonal * of A are overwritten by the corresponding elements of the * tridiagonal matrix T, and the elements above the first * superdiagonal, with the array TAU, represent the unitary * matrix Q as a product of elementary reflectors; if UPLO * = 'L', the diagonal and first subdiagonal of A are over- * written by the corresponding elements of the tridiagonal * matrix T, and the elements below the first subdiagonal, with * the array TAU, represent the unitary matrix Q as a product * of elementary reflectors. See Further Details. * * D (output) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the tridiagonal matrix T: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (N-1) * The off-diagonal elements of the tridiagonal matrix T: * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n-1) . . . H(2) H(1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, * overwriting A(1:i-1,i+1), and tau is stored in TAU(i). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(n-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, * overwriting A(i+2:n,i), and tau is stored in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO, HALF PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ), $ HALF = ( 0.5D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, I1, I1I1, II COMPLEX*16 ALPHA, TAUI * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZHPMV, ZHPR2, ZLARFG * .. * .. External Functions .. LOGICAL LSAME COMPLEX*16 ZDOTC EXTERNAL LSAME, ZDOTC * .. * .. Intrinsic Functions .. INTRINSIC DBLE * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHPTRD', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( UPPER ) THEN * * Reduce the upper triangle of A. * I1 is the index in AP of A(1,I+1). * I1 = N*( N-1 ) / 2 + 1 AP( I1+N-1 ) = DBLE( AP( I1+N-1 ) ) DO 10 I = N - 1, 1, -1 * * Generate elementary reflector H(i) = I - tau * v * v' * to annihilate A(1:i-1,i+1) * ALPHA = AP( I1+I-1 ) CALL ZLARFG( I, ALPHA, AP( I1 ), 1, TAUI ) E( I ) = ALPHA * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(1:i,1:i) * AP( I1+I-1 ) = ONE * * Compute y := tau * A * v storing y in TAU(1:i) * CALL ZHPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, $ 1 ) * * Compute w := y - 1/2 * tau * (y'*v) * v * ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, AP( I1 ), 1 ) CALL ZAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w' - w * v' * CALL ZHPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) * END IF AP( I1+I-1 ) = E( I ) D( I+1 ) = AP( I1+I ) TAU( I ) = TAUI I1 = I1 - I 10 CONTINUE D( 1 ) = AP( 1 ) ELSE * * Reduce the lower triangle of A. II is the index in AP of * A(i,i) and I1I1 is the index of A(i+1,i+1). * II = 1 AP( 1 ) = DBLE( AP( 1 ) ) DO 20 I = 1, N - 1 I1I1 = II + N - I + 1 * * Generate elementary reflector H(i) = I - tau * v * v' * to annihilate A(i+2:n,i) * ALPHA = AP( II+1 ) CALL ZLARFG( N-I, ALPHA, AP( II+2 ), 1, TAUI ) E( I ) = ALPHA * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(i+1:n,i+1:n) * AP( II+1 ) = ONE * * Compute y := tau * A * v storing y in TAU(i:n-1) * CALL ZHPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, $ ZERO, TAU( I ), 1 ) * * Compute w := y - 1/2 * tau * (y'*v) * v * ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, AP( II+1 ), $ 1 ) CALL ZAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w' - w * v' * CALL ZHPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1, $ AP( I1I1 ) ) * END IF AP( II+1 ) = E( I ) D( I ) = AP( II ) TAU( I ) = TAUI II = I1I1 20 CONTINUE D( N ) = AP( II ) END IF * RETURN * * End of ZHPTRD * END DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 AP( * ) * .. * * Purpose * ======= * * ZLANHP returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * complex hermitian matrix A, supplied in packed form. * * Description * =========== * * ZLANHP returns the value * * ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANHP as described * above. * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * hermitian matrix A is supplied. * = 'U': Upper triangular part of A is supplied * = 'L': Lower triangular part of A is supplied * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, ZLANHP is * set to zero. * * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) * The upper or lower triangle of the hermitian matrix A, packed * columnwise in a linear array. The j-th column of A is stored * in the array AP as follows: * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. * Note that the imaginary parts of the diagonal elements need * not be set and are assumed to be zero. * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, K DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN K = 0 DO 20 J = 1, N DO 10 I = K + 1, K + J - 1 VALUE = MAX( VALUE, ABS( AP( I ) ) ) 10 CONTINUE K = K + J VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) ) 20 CONTINUE ELSE K = 1 DO 40 J = 1, N VALUE = MAX( VALUE, ABS( DBLE( AP( K ) ) ) ) DO 30 I = K + 1, K + N - J VALUE = MAX( VALUE, ABS( AP( I ) ) ) 30 CONTINUE K = K + N - J + 1 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * Find normI(A) ( = norm1(A), since A is hermitian). * VALUE = ZERO K = 1 IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 50 CONTINUE WORK( J ) = SUM + ABS( DBLE( AP( K ) ) ) K = K + 1 60 CONTINUE DO 70 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( DBLE( AP( K ) ) ) K = K + 1 DO 90 I = J + 1, N ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 90 CONTINUE VALUE = MAX( VALUE, SUM ) 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL ZLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL ZLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF SUM = 2*SUM K = 1 DO 130 I = 1, N IF( DBLE( AP( K ) ).NE.ZERO ) THEN ABSA = ABS( DBLE( AP( K ) ) ) IF( SCALE.LT.ABSA ) THEN SUM = ONE + SUM*( SCALE / ABSA )**2 SCALE = ABSA ELSE SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN K = K + I + 1 ELSE K = K + N - I + 1 END IF 130 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANHP = VALUE RETURN * * End of ZLANHP * END SUBROUTINE DLASRT( ID, N, D, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER ID INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ) * .. * * Purpose * ======= * * Sort the numbers in D in increasing order (if ID = 'I') or * in decreasing order (if ID = 'D' ). * * Use Quick Sort, reverting to Insertion sort on arrays of * size <= 20. Dimension of STACK limits N to about 2**32. * * Arguments * ========= * * ID (input) CHARACTER*1 * = 'I': sort D in increasing order; * = 'D': sort D in decreasing order. * * N (input) INTEGER * The length of the array D. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the array to be sorted. * On exit, D has been sorted into increasing order * (D(1) <= ... <= D(N) ) or into decreasing order * (D(1) >= ... >= D(N) ), depending on ID. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER SELECT PARAMETER ( SELECT = 20 ) * .. * .. Local Scalars .. INTEGER DIR, ENDD, I, J, START, STKPNT DOUBLE PRECISION D1, D2, D3, DMNMX, TMP * .. * .. Local Arrays .. INTEGER STACK( 2, 32 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input paramters. * INFO = 0 DIR = -1 IF( LSAME( ID, 'D' ) ) THEN DIR = 0 ELSE IF( LSAME( ID, 'I' ) ) THEN DIR = 1 END IF IF( DIR.EQ.-1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASRT', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * STKPNT = 1 STACK( 1, 1 ) = 1 STACK( 2, 1 ) = N 10 CONTINUE START = STACK( 1, STKPNT ) ENDD = STACK( 2, STKPNT ) STKPNT = STKPNT - 1 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN * * Do Insertion sort on D( START:ENDD ) * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * DO 30 I = START + 1, ENDD DO 20 J = I, START + 1, -1 IF( D( J ).GT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 30 END IF 20 CONTINUE 30 CONTINUE * ELSE * * Sort into increasing order * DO 50 I = START + 1, ENDD DO 40 J = I, START + 1, -1 IF( D( J ).LT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 50 END IF 40 CONTINUE 50 CONTINUE * END IF * ELSE IF( ENDD-START.GT.SELECT ) THEN * * Partition D( START:ENDD ) and stack parts, largest one first * * Choose partition entry as median of 3 * D1 = D( START ) D2 = D( ENDD ) I = ( START+ENDD ) / 2 D3 = D( I ) IF( D1.LT.D2 ) THEN IF( D3.LT.D1 ) THEN DMNMX = D1 ELSE IF( D3.LT.D2 ) THEN DMNMX = D3 ELSE DMNMX = D2 END IF ELSE IF( D3.LT.D2 ) THEN DMNMX = D2 ELSE IF( D3.LT.D1 ) THEN DMNMX = D3 ELSE DMNMX = D1 END IF END IF * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * I = START - 1 J = ENDD + 1 60 CONTINUE 70 CONTINUE J = J - 1 IF( D( J ).LT.DMNMX ) $ GO TO 70 80 CONTINUE I = I + 1 IF( D( I ).GT.DMNMX ) $ GO TO 80 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 60 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF ELSE * * Sort into increasing order * I = START - 1 J = ENDD + 1 90 CONTINUE 100 CONTINUE J = J - 1 IF( D( J ).GT.DMNMX ) $ GO TO 100 110 CONTINUE I = I + 1 IF( D( I ).LT.DMNMX ) $ GO TO 110 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 90 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF END IF END IF IF( STKPNT.GT.0 ) $ GO TO 10 RETURN * * End of DLASRT * END DOUBLE COMPLEX FUNCTION ZLADIV( X, Y ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. COMPLEX*16 X, Y * .. * * Purpose * ======= * * ZLADIV := X / Y, where X and Y are complex. The computation of X / Y * will not overflow on an intermediary step unless the results * overflows. * * Arguments * ========= * * X (input) COMPLEX*16 * Y (input) COMPLEX*16 * The complex scalars X and Y. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION ZI, ZR * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DIMAG * .. * .. Executable Statements .. * CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, $ ZI ) ZLADIV = DCMPLX( ZR, ZI ) * RETURN * * End of ZLADIV * END SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 AP( * ) * .. * * Purpose * ======= * * ZHPTRF computes the factorization of a complex Hermitian packed * matrix A using the Bunch-Kaufman diagonal pivoting method: * * A = U*D*U**H or A = L*D*L**H * * where U (or L) is a product of permutation and unit upper (lower) * triangular matrices, and D is Hermitian and block diagonal with * 1-by-1 and 2-by-2 diagonal blocks. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) * On entry, the upper or lower triangle of the Hermitian matrix * A, packed columnwise in a linear array. The j-th column of A * is stored in the array AP as follows: * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. * * On exit, the block diagonal matrix D and the multipliers used * to obtain the factor U or L, stored as a packed triangular * matrix overwriting A (see below for further details). * * IPIV (output) INTEGER array, dimension (N) * Details of the interchanges and the block structure of D. * If IPIV(k) > 0, then rows and columns k and IPIV(k) were * interchanged and D(k,k) is a 1-by-1 diagonal block. * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, D(i,i) is exactly zero. The factorization * has been completed, but the block diagonal matrix D is * exactly singular, and division by zero will occur if it * is used to solve a system of equations. * * Further Details * =============== * * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services * Company * * If UPLO = 'U', then A = U*D*U', where * U = P(n)*U(n)* ... *P(k)U(k)* ..., * i.e., U is a product of terms P(k)*U(k), where k decreases from n to * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such * that if the diagonal block D(k) is of order s (s = 1 or 2), then * * ( I v 0 ) k-s * U(k) = ( 0 I 0 ) s * ( 0 0 I ) n-k * k-s s n-k * * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), * and A(k,k), and v overwrites A(1:k-2,k-1:k). * * If UPLO = 'L', then A = L*D*L', where * L = P(1)*L(1)* ... *P(k)*L(k)* ..., * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such * that if the diagonal block D(k) is of order s (s = 1 or 2), then * * ( I 0 0 ) k-1 * L(k) = ( 0 I 0 ) s * ( 0 v I ) n-k-s+1 * k-1 s n-k-s+1 * * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, $ KSTEP, KX, NPP DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, ROWMAX, $ TT COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, ZDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAPY2 EXTERNAL LSAME, IZAMAX, DLAPY2 * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZHPR, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHPTRF', -INFO ) RETURN END IF * * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT * IF( UPPER ) THEN * * Factorize A as U*D*U' using the upper triangle of A * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2 * K = N KC = ( N-1 )*N / 2 + 1 10 CONTINUE KNC = KC * * If K < 1, exit from loop * IF( K.LT.1 ) $ GO TO 110 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( DBLE( AP( KC+K-1 ) ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.GT.1 ) THEN IMAX = IZAMAX( K-1, AP( KC ), 1 ) COLMAX = CABS1( AP( KC+IMAX-1 ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * ROWMAX = ZERO JMAX = IMAX KX = IMAX*( IMAX+1 ) / 2 + IMAX DO 20 J = IMAX + 1, K IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN ROWMAX = CABS1( AP( KX ) ) JMAX = J END IF KX = KX + J 20 CONTINUE KPC = ( IMAX-1 )*IMAX / 2 + 1 IF( IMAX.GT.1 ) THEN JMAX = IZAMAX( IMAX-1, AP( KPC ), 1 ) ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-1 ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( DBLE( AP( KPC+IMAX-1 ) ) ).GE.ALPHA* $ ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K - KSTEP + 1 IF( KSTEP.EQ.2 ) $ KNC = KNC - K + 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the leading * submatrix A(1:k,1:k) * CALL ZSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) KX = KPC + KP - 1 DO 30 J = KP + 1, KK - 1 KX = KX + J - 1 T = DCONJG( AP( KNC+J-1 ) ) AP( KNC+J-1 ) = DCONJG( AP( KX ) ) AP( KX ) = T 30 CONTINUE AP( KX+KK-1 ) = DCONJG( AP( KX+KK-1 ) ) R1 = DBLE( AP( KNC+KK-1 ) ) AP( KNC+KK-1 ) = DBLE( AP( KPC+KP-1 ) ) AP( KPC+KP-1 ) = R1 IF( KSTEP.EQ.2 ) THEN AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) ) T = AP( KC+K-2 ) AP( KC+K-2 ) = AP( KC+KP-1 ) AP( KC+KP-1 ) = T END IF ELSE AP( KC+K-1 ) = DBLE( AP( KC+K-1 ) ) IF( KSTEP.EQ.2 ) $ AP( KC-1 ) = DBLE( AP( KC-1 ) ) END IF * * Update the leading submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = U(k)*D(k) * * where U(k) is the k-th column of U * * Perform a rank-1 update of A(1:k-1,1:k-1) as * * A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' * R1 = ONE / DBLE( AP( KC+K-1 ) ) CALL ZHPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) * * Store U(k) in column k * CALL ZDSCAL( K-1, R1, AP( KC ), 1 ) ELSE * * 2-by-2 pivot block D(k): columns k and k-1 now hold * * ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U * * Perform a rank-2 update of A(1:k-2,1:k-2) as * * A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' * = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' * IF( K.GT.2 ) THEN * D = DLAPY2( DBLE( AP( K-1+( K-1 )*K / 2 ) ), $ DIMAG( AP( K-1+( K-1 )*K / 2 ) ) ) D22 = DBLE( AP( K-1+( K-2 )*( K-1 ) / 2 ) ) / D D11 = DBLE( AP( K+( K-1 )*K / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D12 = AP( K-1+( K-1 )*K / 2 ) / D D = TT / D * DO 50 J = K - 2, 1, -1 WKM1 = D*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- $ DCONJG( D12 )*AP( J+( K-1 )*K / 2 ) ) WK = D*( D22*AP( J+( K-1 )*K / 2 )-D12* $ AP( J+( K-2 )*( K-1 ) / 2 ) ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*DCONJG( WK ) - $ AP( I+( K-2 )*( K-1 ) / 2 )*DCONJG( WKM1 ) 40 CONTINUE AP( J+( K-1 )*K / 2 ) = WK AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1 AP( J+( J-1 )*J / 2 ) = DCMPLX( DBLE( AP( J+( J- $ 1 )*J / 2 ) ), 0.0D+0 ) 50 CONTINUE * END IF * END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF * * Decrease K and return to the start of the main loop * K = K - KSTEP KC = KNC - K GO TO 10 * ELSE * * Factorize A as L*D*L' using the lower triangle of A * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2 * K = 1 KC = 1 NPP = N*( N+1 ) / 2 60 CONTINUE KNC = KC * * If K > N, exit from loop * IF( K.GT.N ) $ GO TO 110 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( DBLE( AP( KC ) ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.LT.N ) THEN IMAX = K + IZAMAX( N-K, AP( KC+1 ), 1 ) COLMAX = CABS1( AP( KC+IMAX-K ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K AP( KC ) = DBLE( AP( KC ) ) ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * ROWMAX = ZERO KX = KC + IMAX - K DO 70 J = K, IMAX - 1 IF( CABS1( AP( KX ) ).GT.ROWMAX ) THEN ROWMAX = CABS1( AP( KX ) ) JMAX = J END IF KX = KX + N - J 70 CONTINUE KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 IF( IMAX.LT.N ) THEN JMAX = IMAX + IZAMAX( N-IMAX, AP( KPC+1 ), 1 ) ROWMAX = MAX( ROWMAX, CABS1( AP( KPC+JMAX-IMAX ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( DBLE( AP( KPC ) ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K + KSTEP - 1 IF( KSTEP.EQ.2 ) $ KNC = KNC + N - K + 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the trailing * submatrix A(k:n,k:n) * IF( KP.LT.N ) $ CALL ZSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ), $ 1 ) KX = KNC + KP - KK DO 80 J = KK + 1, KP - 1 KX = KX + N - J + 1 T = DCONJG( AP( KNC+J-KK ) ) AP( KNC+J-KK ) = DCONJG( AP( KX ) ) AP( KX ) = T 80 CONTINUE AP( KNC+KP-KK ) = DCONJG( AP( KNC+KP-KK ) ) R1 = DBLE( AP( KNC ) ) AP( KNC ) = DBLE( AP( KPC ) ) AP( KPC ) = R1 IF( KSTEP.EQ.2 ) THEN AP( KC ) = DBLE( AP( KC ) ) T = AP( KC+1 ) AP( KC+1 ) = AP( KC+KP-K ) AP( KC+KP-K ) = T END IF ELSE AP( KC ) = DBLE( AP( KC ) ) IF( KSTEP.EQ.2 ) $ AP( KNC ) = DBLE( AP( KNC ) ) END IF * * Update the trailing submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = L(k)*D(k) * * where L(k) is the k-th column of L * IF( K.LT.N ) THEN * * Perform a rank-1 update of A(k+1:n,k+1:n) as * * A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' * R1 = ONE / DBLE( AP( KC ) ) CALL ZHPR( UPLO, N-K, -R1, AP( KC+1 ), 1, $ AP( KC+N-K+1 ) ) * * Store L(k) in column K * CALL ZDSCAL( N-K, R1, AP( KC+1 ), 1 ) END IF ELSE * * 2-by-2 pivot block D(k): columns K and K+1 now hold * * ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L * IF( K.LT.N-1 ) THEN * * Perform a rank-2 update of A(k+2:n,k+2:n) as * * A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' * = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' * * where L(k) and L(k+1) are the k-th and (k+1)-th * columns of L * D = DLAPY2( DBLE( AP( K+1+( K-1 )*( 2*N-K ) / 2 ) ), $ DIMAG( AP( K+1+( K-1 )*( 2*N-K ) / 2 ) ) ) D11 = DBLE( AP( K+1+K*( 2*N-K-1 ) / 2 ) ) / D D22 = DBLE( AP( K+( K-1 )*( 2*N-K ) / 2 ) ) / D TT = ONE / ( D11*D22-ONE ) D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) / D D = TT / D * DO 100 J = K + 2, N WK = D*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-D21* $ AP( J+K*( 2*N-K-1 ) / 2 ) ) WKP1 = D*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- $ DCONJG( D21 )*AP( J+( K-1 )*( 2*N-K ) / $ 2 ) ) DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / $ 2 )*DCONJG( WK ) - AP( I+K*( 2*N-K-1 ) / 2 )* $ DCONJG( WKP1 ) 90 CONTINUE AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1 AP( J+( J-1 )*( 2*N-J ) / 2 ) $ = DCMPLX( DBLE( AP( J+( J-1 )*( 2*N-J ) / 2 ) ), $ 0.0D+0 ) 100 CONTINUE END IF END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF * * Increase K and return to the start of the main loop * K = K + KSTEP KC = KNC + N - K + 2 GO TO 60 * END IF * 110 CONTINUE RETURN * * End of ZHPTRF * END SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AP( * ) * .. * * Purpose * ======= * * DSPTRF computes the factorization of a real symmetric matrix A stored * in packed format using the Bunch-Kaufman diagonal pivoting method: * * A = U*D*U**T or A = L*D*L**T * * where U (or L) is a product of permutation and unit upper (lower) * triangular matrices, and D is symmetric and block diagonal with * 1-by-1 and 2-by-2 diagonal blocks. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) * On entry, the upper or lower triangle of the symmetric matrix * A, packed columnwise in a linear array. The j-th column of A * is stored in the array AP as follows: * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. * * On exit, the block diagonal matrix D and the multipliers used * to obtain the factor U or L, stored as a packed triangular * matrix overwriting A (see below for further details). * * IPIV (output) INTEGER array, dimension (N) * Details of the interchanges and the block structure of D. * If IPIV(k) > 0, then rows and columns k and IPIV(k) were * interchanged and D(k,k) is a 1-by-1 diagonal block. * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, D(i,i) is exactly zero. The factorization * has been completed, but the block diagonal matrix D is * exactly singular, and division by zero will occur if it * is used to solve a system of equations. * * Further Details * =============== * * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services * Company * * If UPLO = 'U', then A = U*D*U', where * U = P(n)*U(n)* ... *P(k)U(k)* ..., * i.e., U is a product of terms P(k)*U(k), where k decreases from n to * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such * that if the diagonal block D(k) is of order s (s = 1 or 2), then * * ( I v 0 ) k-s * U(k) = ( 0 I 0 ) s * ( 0 0 I ) n-k * k-s s n-k * * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), * and A(k,k), and v overwrites A(1:k-2,k-1:k). * * If UPLO = 'L', then A = L*D*L', where * L = P(1)*L(1)* ... *P(k)*L(k)* ..., * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such * that if the diagonal block D(k) is of order s (s = 1 or 2), then * * ( I 0 0 ) k-1 * L(k) = ( 0 I 0 ) s * ( 0 v I ) n-k-s+1 * k-1 s n-k-s+1 * * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, $ KSTEP, KX, NPP DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, $ ROWMAX, T, WK, WKM1, WKP1 * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX EXTERNAL LSAME, IDAMAX * .. * .. External Subroutines .. EXTERNAL DSCAL, DSPR, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRF', -INFO ) RETURN END IF * * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT * IF( UPPER ) THEN * * Factorize A as U*D*U' using the upper triangle of A * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2 * K = N KC = ( N-1 )*N / 2 + 1 10 CONTINUE KNC = KC * * If K < 1, exit from loop * IF( K.LT.1 ) $ GO TO 110 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( AP( KC+K-1 ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, AP( KC ), 1 ) COLMAX = ABS( AP( KC+IMAX-1 ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * ROWMAX = ZERO JMAX = IMAX KX = IMAX*( IMAX+1 ) / 2 + IMAX DO 20 J = IMAX + 1, K IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN ROWMAX = ABS( AP( KX ) ) JMAX = J END IF KX = KX + J 20 CONTINUE KPC = ( IMAX-1 )*IMAX / 2 + 1 IF( IMAX.GT.1 ) THEN JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K - KSTEP + 1 IF( KSTEP.EQ.2 ) $ KNC = KNC - K + 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the leading * submatrix A(1:k,1:k) * CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) KX = KPC + KP - 1 DO 30 J = KP + 1, KK - 1 KX = KX + J - 1 T = AP( KNC+J-1 ) AP( KNC+J-1 ) = AP( KX ) AP( KX ) = T 30 CONTINUE T = AP( KNC+KK-1 ) AP( KNC+KK-1 ) = AP( KPC+KP-1 ) AP( KPC+KP-1 ) = T IF( KSTEP.EQ.2 ) THEN T = AP( KC+K-2 ) AP( KC+K-2 ) = AP( KC+KP-1 ) AP( KC+KP-1 ) = T END IF END IF * * Update the leading submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = U(k)*D(k) * * where U(k) is the k-th column of U * * Perform a rank-1 update of A(1:k-1,1:k-1) as * * A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' * R1 = ONE / AP( KC+K-1 ) CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) * * Store U(k) in column k * CALL DSCAL( K-1, R1, AP( KC ), 1 ) ELSE * * 2-by-2 pivot block D(k): columns k and k-1 now hold * * ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U * * Perform a rank-2 update of A(1:k-2,1:k-2) as * * A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' * = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' * IF( K.GT.2 ) THEN * D12 = AP( K-1+( K-1 )*K / 2 ) D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 D11 = AP( K+( K-1 )*K / 2 ) / D12 T = ONE / ( D11*D22-ONE ) D12 = T / D12 * DO 50 J = K - 2, 1, -1 WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- $ AP( J+( K-1 )*K / 2 ) ) WK = D12*( D22*AP( J+( K-1 )*K / 2 )- $ AP( J+( K-2 )*( K-1 ) / 2 ) ) DO 40 I = J, 1, -1 AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - $ AP( I+( K-1 )*K / 2 )*WK - $ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1 40 CONTINUE AP( J+( K-1 )*K / 2 ) = WK AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1 50 CONTINUE * END IF * END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF * * Decrease K and return to the start of the main loop * K = K - KSTEP KC = KNC - K GO TO 10 * ELSE * * Factorize A as L*D*L' using the lower triangle of A * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2 * K = 1 KC = 1 NPP = N*( N+1 ) / 2 60 CONTINUE KNC = KC * * If K > N, exit from loop * IF( K.GT.N ) $ GO TO 110 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( AP( KC ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) COLMAX = ABS( AP( KC+IMAX-K ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * ROWMAX = ZERO KX = KC + IMAX - K DO 70 J = K, IMAX - 1 IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN ROWMAX = ABS( AP( KX ) ) JMAX = J END IF KX = KX + N - J 70 CONTINUE KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 IF( IMAX.LT.N ) THEN JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K + KSTEP - 1 IF( KSTEP.EQ.2 ) $ KNC = KNC + N - K + 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the trailing * submatrix A(k:n,k:n) * IF( KP.LT.N ) $ CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ), $ 1 ) KX = KNC + KP - KK DO 80 J = KK + 1, KP - 1 KX = KX + N - J + 1 T = AP( KNC+J-KK ) AP( KNC+J-KK ) = AP( KX ) AP( KX ) = T 80 CONTINUE T = AP( KNC ) AP( KNC ) = AP( KPC ) AP( KPC ) = T IF( KSTEP.EQ.2 ) THEN T = AP( KC+1 ) AP( KC+1 ) = AP( KC+KP-K ) AP( KC+KP-K ) = T END IF END IF * * Update the trailing submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = L(k)*D(k) * * where L(k) is the k-th column of L * IF( K.LT.N ) THEN * * Perform a rank-1 update of A(k+1:n,k+1:n) as * * A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' * R1 = ONE / AP( KC ) CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1, $ AP( KC+N-K+1 ) ) * * Store L(k) in column K * CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) END IF ELSE * * 2-by-2 pivot block D(k): columns K and K+1 now hold * * ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L * IF( K.LT.N-1 ) THEN * * Perform a rank-2 update of A(k+2:n,k+2:n) as * * A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' * = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' * D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 * DO 100 J = K + 2, N WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- $ AP( J+K*( 2*N-K-1 ) / 2 ) ) WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) * DO 90 I = J, N AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1 90 CONTINUE * AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1 * 100 CONTINUE END IF END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF * * Increase K and return to the start of the main loop * K = K + KSTEP KC = KNC + N - K + 2 GO TO 60 * END IF * 110 CONTINUE RETURN * * End of DSPTRF * END SUBROUTINE DLADIV( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q * .. * * Purpose * ======= * * DLADIV performs complex division in real arithmetic * * a + i*b * p + i*q = --------- * c + i*d * * The algorithm is due to Robert L. Smith and can be found * in D. Knuth, The art of Computer Programming, Vol.2, p.195 * * Arguments * ========= * * A (input) DOUBLE PRECISION * B (input) DOUBLE PRECISION * C (input) DOUBLE PRECISION * D (input) DOUBLE PRECISION * The scalars a, b, c, and d in the above expression. * * P (output) DOUBLE PRECISION * Q (output) DOUBLE PRECISION * The scalars p and q in the above expression. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION E, F * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( ABS( D ).LT.ABS( C ) ) THEN E = D / C F = C + D*E P = ( A+B*E ) / F Q = ( B-A*E ) / F ELSE E = C / D F = D + C*E P = ( B+A*E ) / F Q = ( -A+B*E ) / F END IF * RETURN * * End of DLADIV * END SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLASSQ returns the values scl and ssq such that * * ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, * * where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is * assumed to be at least unity and the value of ssq will then satisfy * * 1.0 .le. ssq .le. ( sumsq + 2*n ). * * scale is assumed to be non-negative and scl returns the value * * scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), * i * * scale and sumsq must be supplied in SCALE and SUMSQ respectively. * SCALE and SUMSQ are overwritten by scl and ssq respectively. * * The routine makes only one pass through the vector X. * * Arguments * ========= * * N (input) INTEGER * The number of elements to be used from the vector X. * * X (input) COMPLEX*16 array, dimension (N) * The vector x as described above. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. * * INCX (input) INTEGER * The increment between successive values of the vector X. * INCX > 0. * * SCALE (input/output) DOUBLE PRECISION * On entry, the value scale in the equation above. * On exit, SCALE is overwritten with the value scl . * * SUMSQ (input/output) DOUBLE PRECISION * On entry, the value sumsq in the equation above. * On exit, SUMSQ is overwritten with the value ssq . * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER IX DOUBLE PRECISION TEMP1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( DBLE( X( IX ) ).NE.ZERO ) THEN TEMP1 = ABS( DBLE( X( IX ) ) ) IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF IF( DIMAG( X( IX ) ).NE.ZERO ) THEN TEMP1 = ABS( DIMAG( X( IX ) ) ) IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF 10 CONTINUE END IF * RETURN * * End of ZLASSQ * END SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N COMPLEX*16 ALPHA, TAU * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLARFG generates a complex elementary reflector H of order n, such * that * * H' * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, with beta real, and x is an * (n-1)-element complex vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a complex scalar and v is a complex (n-1)-element * vector. Note that H is not hermitian. * * If the elements of x are all zero and alpha is real, then tau = 0 * and H is taken to be the unit matrix. * * Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) COMPLEX*16 * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) COMPLEX*16 array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX > 0. * * TAU (output) COMPLEX*16 * The value tau. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 COMPLEX*16 ZLADIV EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN * .. * .. External Subroutines .. EXTERNAL ZDSCAL, ZSCAL * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN TAU = ZERO RETURN END IF * XNORM = DZNRM2( N-1, X, INCX ) ALPHR = DBLE( ALPHA ) ALPHI = DIMAG( ALPHA ) * IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) RSAFMN = ONE / SAFMIN * IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * KNT = 0 10 CONTINUE KNT = KNT + 1 CALL ZDSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHI = ALPHI*RSAFMN ALPHR = ALPHR*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DZNRM2( N-1, X, INCX ) ALPHA = DCMPLX( ALPHR, ALPHI ) BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of ZLARFG * END SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( * ), S( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASR performs the transformation * * A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) * * A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) * * where A is an m by n complex matrix and P is an orthogonal matrix, * consisting of a sequence of plane rotations determined by the * parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' * and z = n when SIDE = 'R' or 'r' ): * * When DIRECT = 'F' or 'f' ( Forward sequence ) then * * P = P( z - 1 )*...*P( 2 )*P( 1 ), * * and when DIRECT = 'B' or 'b' ( Backward sequence ) then * * P = P( 1 )*P( 2 )*...*P( z - 1 ), * * where P( k ) is a plane rotation matrix for the following planes: * * when PIVOT = 'V' or 'v' ( Variable pivot ), * the plane ( k, k + 1 ) * * when PIVOT = 'T' or 't' ( Top pivot ), * the plane ( 1, k + 1 ) * * when PIVOT = 'B' or 'b' ( Bottom pivot ), * the plane ( k, z ) * * c( k ) and s( k ) must contain the cosine and sine that define the * matrix P( k ). The two by two plane rotation part of the matrix * P( k ), R( k ), is assumed to be of the form * * R( k ) = ( c( k ) s( k ) ). * ( -s( k ) c( k ) ) * * Arguments * ========= * * SIDE (input) CHARACTER*1 * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A * = 'R': Right, compute A:= A*P' * * DIRECT (input) CHARACTER*1 * Specifies whether P is a forward or backward sequence of * plane rotations. * = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) * = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation * matrix. * = 'V': Variable pivot, the plane (k,k+1) * = 'T': Top pivot, the plane (1,k+1) * = 'B': Bottom pivot, the plane (k,z) * * M (input) INTEGER * The number of rows of the matrix A. If m <= 1, an immediate * return is effected. * * N (input) INTEGER * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * * C, S (input) DOUBLE PRECISION arrays, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' * c(k) and s(k) contain the cosine and sine that define the * matrix P(k). The two by two plane rotation part of the * matrix P(k), R(k), is assumed to be of the form * R( k ) = ( c( k ) s( k ) ). * ( -s( k ) c( k ) ) * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * The m by n matrix A. On exit, A is overwritten by P*A if * SIDE = 'R' or by A*P' if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP COMPLEX*16 TEMP * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P' * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of ZLASR * END SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNG2L generates an m by n complex matrix Q with orthonormal columns, * which is defined as the last n columns of a product of k elementary * reflectors of order m * * Q = H(k) . . . H(2) H(1) * * as returned by ZGEQLF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the (n-k+i)-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGEQLF in the last k columns of its array * argument A. * On exit, the m-by-n matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, II, J, L * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNG2L', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns 1:n-k to columns of the unit matrix * DO 20 J = 1, N - K DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( M-N+J, J ) = ONE 20 CONTINUE * DO 40 I = 1, K II = N - K + I * * Apply H(i) to A(1:m-k+i,1:n-k+i) from the left * A( M-N+II, II ) = ONE CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, $ LDA, WORK ) CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * * Set A(m-k+i+1:m,n-k+i) to zero * DO 30 L = M - N + II + 1, M A( L, II ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of ZUNG2L * END SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNG2R generates an m by n complex matrix Q with orthonormal columns, * which is defined as the first n columns of a product of k elementary * reflectors of order m * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the i-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGEQRF in the first k columns of its array * argument A. * On exit, the m by n matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNG2R', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * * Initialise columns k+1:n to columns of the unit matrix * DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE * DO 40 I = K, 1, -1 * * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN A( I, I ) = ONE CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) * * Set A(1:i-1,i) to zero * DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of ZUNG2R * END SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N COMPLEX*16 TAU * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * ZLARF applies a complex elementary reflector H to a complex M-by-N * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a complex scalar and v is a complex vector. * * If tau = 0, then H is taken to be the unit matrix. * * To apply H' (the conjugate transpose of H), supply conjg(tau) instead * tau. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) COMPLEX*16 array, dimension * (1 + (M-1)*abs(INCV)) if SIDE = 'L' * or (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of H. V is not used if * TAU = 0. * * INCV (input) INTEGER * The increment between elements of v. INCV <> 0. * * TAU (input) COMPLEX*16 * The value tau in the representation of H. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZGERC * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w := C' * v * CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, $ INCV, ZERO, WORK, 1 ) * * C := C - v * w' * CALL ZGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w := C * v * CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - w * v' * CALL ZGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of ZLARF * END INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * Purpose * ======= * * ILAENV is called from the LAPACK routines to choose problem-dependent * parameters for the local environment. See ISPEC for a description of * the parameters. * * This version provides a set of parameters which should give good, * but not optimal, performance on many of the currently available * computers. Users are encouraged to modify this subroutine to set * the tuning parameters for their particular machine using the option * and problem size information in the arguments. * * This routine will not function correctly if it is converted to all * lower case. Converting it to all upper case is allowed. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be returned as the value of * ILAENV. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors * = 8: the crossover point for the multishift QR and QZ methods * for nonsymmetric eigenvalue problems. * = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * =10: ieee NaN arithmetic can be trusted not to trap * =11: infinity arithmetic can be trusted not to trap * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or * lower case. * * OPTS (input) CHARACTER*(*) * The character options to the subroutine NAME, concatenated * into a single character string. For example, UPLO = 'U', * TRANS = 'T', and DIAG = 'N' for a triangular routine would * be specified as OPTS = 'UTN'. * * N1 (input) INTEGER * N2 (input) INTEGER * N3 (input) INTEGER * N4 (input) INTEGER * Problem dimensions for the subroutine NAME; these may not all * be required. * * (ILAENV) (output) INTEGER * >= 0: the value of the parameter specified by ISPEC * < 0: if ILAENV = -k, the k-th argument had an illegal value. * * Further Details * =============== * * The following conventions have been used when calling ILAENV from the * LAPACK routines: * 1) OPTS is a concatenation of all of the character options to * subroutine NAME, in the same order that they appear in the * argument list for NAME, even if they are not used in determining * the value of the parameter specified by ISPEC. * 2) The problem dimensions N1, N2, N3, N4 are specified in the order * that they appear in the argument list for NAME. N1 is used * first, N2 second, and so on, and unused problem dimensions are * passed a value of -1. * 3) The parameter value returned by ILAENV is checked for validity in * the calling subroutine. For example, ILAENV is used to retrieve * the optimal blocksize for STRTRI as follows: * * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) * IF( NB.LE.1 ) NB = MAX( 1, N ) * * ===================================================================== * * .. Local Scalars .. LOGICAL CNAME, SNAME CHARACTER*1 C1 CHARACTER*2 C2, C4 CHARACTER*3 C3 CHARACTER*6 SUBNAM INTEGER I, IC, IZ, NB, NBMIN, NX * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. External Functions .. INTEGER IEEECK EXTERNAL IEEECK * .. * .. Executable Statements .. * GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, $ 1100 ) ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * 100 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1:1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 10 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 10 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN * * EBCDIC character set * IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1:1 ) = CHAR( IC+64 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) $ SUBNAM( I:I ) = CHAR( IC+64 ) 20 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN * * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 30 CONTINUE END IF END IF * C1 = SUBNAM( 1:1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN C2 = SUBNAM( 2:3 ) C3 = SUBNAM( 4:6 ) C4 = C3( 2:3 ) * GO TO ( 110, 200, 300 ) ISPEC * 110 CONTINUE * * ISPEC = 1: block size * * In these examples, separate code is provided for setting NB for * real and complex. We assume that NB will take the same value in * single or double precision. * NB = 1 * IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN NB = 32 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF END IF ILAENV = NB RETURN * 200 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 8 ELSE NBMIN = 8 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF END IF ILAENV = NBMIN RETURN * 300 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 32 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF END IF ILAENV = NX RETURN * 400 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * 500 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * 600 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * 700 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * 800 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * 900 CONTINUE * * ISPEC = 9: maximum size of the subproblems at the bottom of the * computation tree in the divide-and-conquer algorithm * (used by xGELSD and xGESDD) * ILAENV = 25 RETURN * 1000 CONTINUE * * ISPEC = 10: ieee NaN arithmetic can be trusted not to trap * C ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 0, 0.0, 1.0 ) END IF RETURN * 1100 CONTINUE * * ISPEC = 11: infinity arithmetic can be trusted not to trap * C ILAENV = 0 ILAENV = 1 IF( ILAENV.EQ.1 ) THEN ILAENV = IEEECK( 1, 0.0, 1.0 ) END IF RETURN * * End of ILAENV * END SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, ITYPE, LDA, LDB, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ), W( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) * .. * * Purpose * ======= * * ZHEGV computes all the eigenvalues, and optionally, the eigenvectors * of a complex generalized Hermitian-definite eigenproblem, of the form * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. * Here A and B are assumed to be Hermitian and B is also * positive definite. * * Arguments * ========= * * ITYPE (input) INTEGER * Specifies the problem type to be solved: * = 1: A*x = (lambda)*B*x * = 2: A*B*x = (lambda)*x * = 3: B*A*x = (lambda)*x * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangles of A and B are stored; * = 'L': Lower triangles of A and B are stored. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) * On entry, the Hermitian matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * * On exit, if JOBZ = 'V', then if INFO = 0, A contains the * matrix Z of eigenvectors. The eigenvectors are normalized * as follows: * if ITYPE = 1 or 2, Z**H*B*Z = I; * if ITYPE = 3, Z**H*inv(B)*Z = I. * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') * or the lower triangle (if UPLO='L') of A, including the * diagonal, is destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) COMPLEX*16 array, dimension (LDB, N) * On entry, the Hermitian positive definite matrix B. * If UPLO = 'U', the leading N-by-N upper triangular part of B * contains the upper triangular part of the matrix B. * If UPLO = 'L', the leading N-by-N lower triangular part of B * contains the lower triangular part of the matrix B. * * On exit, if INFO <= N, the part of B containing the matrix is * overwritten by the triangular factor U or L from the Cholesky * factorization B = U**H*U or B = L*L**H. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,2*N-1). * For optimal efficiency, LWORK >= (NB+1)*N, * where NB is the blocksize for ZHETRD returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: ZPOTRF or ZHEEV returned an error code: * <= N: if INFO = i, ZHEEV failed to converge; * i off-diagonal elements of an intermediate * tridiagonal form did not converge to zero; * > N: if INFO = N + i, for 1 <= i <= N, then the leading * minor of order i of B is not positive definite. * The factorization of B could not be completed and * no eigenvalues or eigenvectors were computed. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER, WANTZ CHARACTER TRANS INTEGER LWKOPT, NB, NEIG * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZHEEV, ZHEGST, ZPOTRF, ZTRMM, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -11 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = ( NB+1 )*N WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHEGV ', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form a Cholesky factorization of B. * CALL ZPOTRF( UPLO, N, B, LDB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) CALL ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * NEIG = N IF( INFO.GT.0 ) $ NEIG = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)'*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'C' END IF * CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, $ B, LDB, A, LDA ) * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U'*y * IF( UPPER ) THEN TRANS = 'C' ELSE TRANS = 'N' END IF * CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, $ B, LDB, A, LDA ) END IF END IF * WORK( 1 ) = LWKOPT * RETURN * * End of ZHEGV * END SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, RWORK, IWORK, IFAIL, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION RWORK( * ), W( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ), $ Z( LDZ, * ) * .. * * Purpose * ======= * * ZHEGVX computes selected eigenvalues, and optionally, eigenvectors * of a complex generalized Hermitian-definite eigenproblem, of the form * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and * B are assumed to be Hermitian and B is also positive definite. * Eigenvalues and eigenvectors can be selected by specifying either a * range of values or a range of indices for the desired eigenvalues. * * Arguments * ========= * * ITYPE (input) INTEGER * Specifies the problem type to be solved: * = 1: A*x = (lambda)*B*x * = 2: A*B*x = (lambda)*x * = 3: B*A*x = (lambda)*x * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * RANGE (input) CHARACTER*1 * = 'A': all eigenvalues will be found. * = 'V': all eigenvalues in the half-open interval (VL,VU] * will be found. * = 'I': the IL-th through IU-th eigenvalues will be found. ** * UPLO (input) CHARACTER*1 * = 'U': Upper triangles of A and B are stored; * = 'L': Lower triangles of A and B are stored. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) * On entry, the Hermitian matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * * On exit, the lower triangle (if UPLO='L') or the upper * triangle (if UPLO='U') of A, including the diagonal, is * destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) COMPLEX*16 array, dimension (LDB, N) * On entry, the Hermitian matrix B. If UPLO = 'U', the * leading N-by-N upper triangular part of B contains the * upper triangular part of the matrix B. If UPLO = 'L', * the leading N-by-N lower triangular part of B contains * the lower triangular part of the matrix B. * * On exit, if INFO <= N, the part of B containing the matrix is * overwritten by the triangular factor U or L from the Cholesky * factorization B = U**H*U or B = L*L**H. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * VL (input) DOUBLE PRECISION * VU (input) DOUBLE PRECISION * If RANGE='V', the lower and upper bounds of the interval to * be searched for eigenvalues. VL < VU. * Not referenced if RANGE = 'A' or 'I'. * * IL (input) INTEGER * IU (input) INTEGER * If RANGE='I', the indices (in ascending order) of the * smallest and largest eigenvalues to be returned. * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. * Not referenced if RANGE = 'A' or 'V'. * * ABSTOL (input) DOUBLE PRECISION * The absolute error tolerance for the eigenvalues. * An approximate eigenvalue is accepted as converged * when it is determined to lie in an interval [a,b] * of width less than or equal to * * ABSTOL + EPS * max( |a|,|b| ) , * * where EPS is the machine precision. If ABSTOL is less than * or equal to zero, then EPS*|T| will be used in its place, * where |T| is the 1-norm of the tridiagonal matrix obtained * by reducing A to tridiagonal form. * * Eigenvalues will be computed most accurately when ABSTOL is * set to twice the underflow threshold 2*DLAMCH('S'), not zero. * If this routine returns with INFO>0, indicating that some * eigenvectors did not converge, try setting ABSTOL to * 2*DLAMCH('S'). * * M (output) INTEGER * The total number of eigenvalues found. 0 <= M <= N. * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. * * W (output) DOUBLE PRECISION array, dimension (N) * The first M elements contain the selected * eigenvalues in ascending order. * * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) * If JOBZ = 'N', then Z is not referenced. * If JOBZ = 'V', then if INFO = 0, the first M columns of Z * contain the orthonormal eigenvectors of the matrix A * corresponding to the selected eigenvalues, with the i-th * column of Z holding the eigenvector associated with W(i). * The eigenvectors are normalized as follows: * if ITYPE = 1 or 2, Z**T*B*Z = I; * if ITYPE = 3, Z**T*inv(B)*Z = I. * * If an eigenvector fails to converge, then that column of Z * contains the latest approximation to the eigenvector, and the * index of the eigenvector is returned in IFAIL. * Note: the user must ensure that at least max(1,M) columns are * supplied in the array Z; if RANGE = 'V', the exact value of M * is not known in advance and an upper bound must be used. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * JOBZ = 'V', LDZ >= max(1,N). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,2*N-1). * For optimal efficiency, LWORK >= (NB+1)*N, * where NB is the blocksize for ZHETRD returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) * * IWORK (workspace) INTEGER array, dimension (5*N) * * IFAIL (output) INTEGER array, dimension (N) * If JOBZ = 'V', then if INFO = 0, the first M elements of * IFAIL are zero. If INFO > 0, then IFAIL contains the * indices of the eigenvectors that failed to converge. * If JOBZ = 'N', then IFAIL is not referenced. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: ZPOTRF or ZHEEVX returned an error code: * <= N: if INFO = i, ZHEEVX failed to converge; * i eigenvectors failed to converge. Their indices * are stored in array IFAIL. * > N: if INFO = N + i, for 1 <= i <= N, then the leading * minor of order i of B is not positive definite. * The factorization of B could not be completed and * no eigenvalues or eigenvectors were computed. * * Further Details * =============== * * Based on contributions by * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== * * .. Parameters .. COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ CHARACTER TRANS INTEGER LOPT, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZHEEVX, ZHEGST, ZPOTRF, ZTRMM, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -3 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( VALEIG .AND. N.GT.0 ) THEN IF( VU.LE.VL ) $ INFO = -11 ELSE IF( INDEIG .AND. IL.LT.1 ) THEN INFO = -12 ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN INFO = -13 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -18 ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -20 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = ( NB+1 )*N WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHEGVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Form a Cholesky factorization of B. * CALL ZPOTRF( UPLO, N, B, LDB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) CALL ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, $ INFO ) LOPT = WORK( 1 ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * IF( INFO.GT.0 ) $ M = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)'*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'C' END IF * CALL ZTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B, $ LDB, Z, LDZ ) * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U'*y * IF( UPPER ) THEN TRANS = 'C' ELSE TRANS = 'N' END IF * CALL ZTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, CONE, B, $ LDB, Z, LDZ ) END IF END IF * * Set WORK(1) to optimal complex workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of ZHEGVX * END SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DSYTRF computes the factorization of a real symmetric matrix A using * the Bunch-Kaufman diagonal pivoting method. The form of the * factorization is * * A = U*D*U**T or A = L*D*L**T * * where U (or L) is a product of permutation and unit upper (lower) * triangular matrices, and D is symmetric and block diagonal with * 1-by-1 and 2-by-2 diagonal blocks. * * This is the blocked version of the algorithm, calling Level 3 BLAS. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, the block diagonal matrix D and the multipliers used * to obtain the factor U or L (see below for further details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (output) INTEGER array, dimension (N) * Details of the interchanges and the block structure of D. * If IPIV(k) > 0, then rows and columns k and IPIV(k) were * interchanged and D(k,k) is a 1-by-1 diagonal block. * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of WORK. LWORK >=1. For best performance * LWORK >= N*NB, where NB is the block size returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, D(i,i) is exactly zero. The factorization * has been completed, but the block diagonal matrix D is * exactly singular, and division by zero will occur if it * is used to solve a system of equations. * * Further Details * =============== * * If UPLO = 'U', then A = U*D*U', where * U = P(n)*U(n)* ... *P(k)U(k)* ..., * i.e., U is a product of terms P(k)*U(k), where k decreases from n to * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such * that if the diagonal block D(k) is of order s (s = 1 or 2), then * * ( I v 0 ) k-s * U(k) = ( 0 I 0 ) s * ( 0 0 I ) n-k * k-s s n-k * * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), * and A(k,k), and v overwrites A(1:k-2,k-1:k). * * If UPLO = 'L', then A = L*D*L', where * L = P(1)*L(1)* ... *P(k)*L(k)* ..., * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such * that if the diagonal block D(k) is of order s (s = 1 or 2), then * * ( I 0 0 ) k-1 * L(k) = ( 0 I 0 ) s * ( 0 v I ) n-k-s+1 * k-1 s n-k-s+1 * * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLASYF, DSYTF2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -7 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size * NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * NBMIN = 2 LDWORK = N IF( NB.GT.1 .AND. NB.LT.N ) THEN IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN NB = MAX( LWORK / LDWORK, 1 ) NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) ) END IF ELSE IWS = 1 END IF IF( NB.LT.NBMIN ) $ NB = N * IF( UPPER ) THEN * * Factorize A as U*D*U' using the upper triangle of A * * K is the main loop index, decreasing from N to 1 in steps of * KB, where KB is the number of columns factorized by DLASYF; * KB is either NB or NB-1, or K for the last block * K = N 10 CONTINUE * * If K < 1, exit from loop * IF( K.LT.1 ) $ GO TO 40 * IF( K.GT.NB ) THEN * * Factorize columns k-kb+1:k of A and use blocked code to * update columns 1:k-kb * CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, $ IINFO ) ELSE * * Use unblocked code to factorize columns 1:k of A * CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO ) KB = K END IF * * Set INFO on the first occurrence of a zero pivot * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO * * Decrease K and return to the start of the main loop * K = K - KB GO TO 10 * ELSE * * Factorize A as L*D*L' using the lower triangle of A * * K is the main loop index, increasing from 1 to N in steps of * KB, where KB is the number of columns factorized by DLASYF; * KB is either NB or NB-1, or N-K+1 for the last block * K = 1 20 CONTINUE * * If K > N, exit from loop * IF( K.GT.N ) $ GO TO 40 * IF( K.LE.N-NB ) THEN * * Factorize columns k:k+kb-1 of A and use blocked code to * update columns k+kb:n * CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), $ WORK, LDWORK, IINFO ) ELSE * * Use unblocked code to factorize columns k:n of A * CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO ) KB = N - K + 1 END IF * * Set INFO on the first occurrence of a zero pivot * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO + K - 1 * * Adjust IPIV * DO 30 J = K, K + KB - 1 IF( IPIV( J ).GT.0 ) THEN IPIV( J ) = IPIV( J ) + K - 1 ELSE IPIV( J ) = IPIV( J ) - K + 1 END IF 30 CONTINUE * * Increase K and return to the start of the main loop * K = K + KB GO TO 20 * END IF * 40 CONTINUE WORK( 1 ) = LWKOPT RETURN * * End of DSYTRF * END SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DSYTRI computes the inverse of a real symmetric indefinite matrix * A using the factorization A = U*D*U**T or A = L*D*L**T computed by * DSYTRF. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the details of the factorization are stored * as an upper or lower triangular matrix. * = 'U': Upper triangular, form is A = U*D*U**T; * = 'L': Lower triangular, form is A = L*D*L**T. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the block diagonal matrix D and the multipliers * used to obtain the factor U or L as computed by DSYTRF. * * On exit, if INFO = 0, the (symmetric) inverse of the original * matrix. If UPLO = 'U', the upper triangular part of the * inverse is formed and the part of A below the diagonal is not * referenced; if UPLO = 'L' the lower triangular part of the * inverse is formed and the part of A above the diagonal is * not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (input) INTEGER array, dimension (N) * Details of the interchanges and the block structure of D * as determined by DSYTRF. * * WORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its * inverse could not be computed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER K, KP, KSTEP DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. External Subroutines .. EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check that the diagonal matrix D is nonsingular. * IF( UPPER ) THEN * * Upper triangular storage: examine D from bottom to top * DO 10 INFO = N, 1, -1 IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) $ RETURN 10 CONTINUE ELSE * * Lower triangular storage: examine D from top to bottom. * DO 20 INFO = 1, N IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) $ RETURN 20 CONTINUE END IF INFO = 0 * IF( UPPER ) THEN * * Compute inv(A) from the factorization A = U*D*U'. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = 1 30 CONTINUE * * If K > N, exit from loop. * IF( K.GT.N ) $ GO TO 40 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Invert the diagonal block. * A( K, K ) = ONE / A( K, K ) * * Compute column K of the inverse. * IF( K.GT.1 ) THEN CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, $ A( 1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), $ 1 ) END IF KSTEP = 1 ELSE * * 2 x 2 diagonal block * * Invert the diagonal block. * T = ABS( A( K, K+1 ) ) AK = A( K, K ) / T AKP1 = A( K+1, K+1 ) / T AKKP1 = A( K, K+1 ) / T D = T*( AK*AKP1-ONE ) A( K, K ) = AKP1 / D A( K+1, K+1 ) = AK / D A( K, K+1 ) = -AKKP1 / D * * Compute columns K and K+1 of the inverse. * IF( K.GT.1 ) THEN CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, $ A( 1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), $ 1 ) A( K, K+1 ) = A( K, K+1 ) - $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, $ A( 1, K+1 ), 1 ) A( K+1, K+1 ) = A( K+1, K+1 ) - $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) END IF KSTEP = 2 END IF * KP = ABS( IPIV( K ) ) IF( KP.NE.K ) THEN * * Interchange rows and columns K and KP in the leading * submatrix A(1:k+1,1:k+1) * CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP IF( KSTEP.EQ.2 ) THEN TEMP = A( K, K+1 ) A( K, K+1 ) = A( KP, K+1 ) A( KP, K+1 ) = TEMP END IF END IF * K = K + KSTEP GO TO 30 40 CONTINUE * ELSE * * Compute inv(A) from the factorization A = L*D*L'. * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2, depending on the size of the diagonal blocks. * K = N 50 CONTINUE * * If K < 1, exit from loop. * IF( K.LT.1 ) $ GO TO 60 * IF( IPIV( K ).GT.0 ) THEN * * 1 x 1 diagonal block * * Invert the diagonal block. * A( K, K ) = ONE / A( K, K ) * * Compute column K of the inverse. * IF( K.LT.N ) THEN CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, $ ZERO, A( K+1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), $ 1 ) END IF KSTEP = 1 ELSE * * 2 x 2 diagonal block * * Invert the diagonal block. * T = ABS( A( K, K-1 ) ) AK = A( K-1, K-1 ) / T AKP1 = A( K, K ) / T AKKP1 = A( K, K-1 ) / T D = T*( AK*AKP1-ONE ) A( K-1, K-1 ) = AKP1 / D A( K, K ) = AK / D A( K, K-1 ) = -AKKP1 / D * * Compute columns K-1 and K of the inverse. * IF( K.LT.N ) THEN CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, $ ZERO, A( K+1, K ), 1 ) A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), $ 1 ) A( K, K-1 ) = A( K, K-1 ) - $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), $ 1 ) CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, $ ZERO, A( K+1, K-1 ), 1 ) A( K-1, K-1 ) = A( K-1, K-1 ) - $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) END IF KSTEP = 2 END IF * KP = ABS( IPIV( K ) ) IF( KP.NE.K ) THEN * * Interchange rows and columns K and KP in the trailing * submatrix A(k-1:n,k-1:n) * IF( KP.LT.N ) $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) TEMP = A( K, K ) A( K, K ) = A( KP, KP ) A( KP, KP ) = TEMP IF( KSTEP.EQ.2 ) THEN TEMP = A( K, K-1 ) A( K, K-1 ) = A( KP, K-1 ) A( KP, K-1 ) = TEMP END IF END IF * K = K - KSTEP GO TO 50 60 CONTINUE END IF * RETURN * * End of DSYTRI * END INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1998 * * .. Scalar Arguments .. INTEGER ISPEC REAL ONE, ZERO * .. * * Purpose * ======= * * IEEECK is called from the ILAENV to verify that Infinity and * possibly NaN arithmetic is safe (i.e. will not trap). * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies whether to test just for inifinity arithmetic * or whether to test for infinity and NaN arithmetic. * = 0: Verify infinity arithmetic only. * = 1: Verify infinity and NaN arithmetic. * * ZERO (input) REAL * Must contain the value 0.0 * This is passed to prevent the compiler from optimizing * away this code. * * ONE (input) REAL * Must contain the value 1.0 * This is passed to prevent the compiler from optimizing * away this code. * * RETURN VALUE: INTEGER * = 0: Arithmetic failed to produce the correct answers * = 1: Arithmetic produced the correct answers * * .. Local Scalars .. REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, $ NEGZRO, NEWZRO, POSINF * .. * .. Executable Statements .. IEEECK = 1 * POSINF = ONE / ZERO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * NEGINF = -ONE / ZERO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEGZRO = ONE / ( NEGINF+ONE ) IF( NEGZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEGINF = ONE / NEGZRO IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * NEWZRO = NEGZRO + ZERO IF( NEWZRO.NE.ZERO ) THEN IEEECK = 0 RETURN END IF * POSINF = ONE / NEWZRO IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * NEGINF = NEGINF*POSINF IF( NEGINF.GE.ZERO ) THEN IEEECK = 0 RETURN END IF * POSINF = POSINF*POSINF IF( POSINF.LE.ONE ) THEN IEEECK = 0 RETURN END IF * * * * * Return if we were only asked to check infinity arithmetic * IF( ISPEC.EQ.0 ) $ RETURN * NAN1 = POSINF + NEGINF * NAN2 = POSINF / NEGINF * NAN3 = POSINF / POSINF * NAN4 = POSINF*ZERO * NAN5 = NEGINF*NEGZRO * NAN6 = NAN5*0.0 * IF( NAN1.EQ.NAN1 ) THEN IEEECK = 0 RETURN END IF * IF( NAN2.EQ.NAN2 ) THEN IEEECK = 0 RETURN END IF * IF( NAN3.EQ.NAN3 ) THEN IEEECK = 0 RETURN END IF * IF( NAN4.EQ.NAN4 ) THEN IEEECK = 0 RETURN END IF * IF( NAN5.EQ.NAN5 ) THEN IEEECK = 0 RETURN END IF * IF( NAN6.EQ.NAN6 ) THEN IEEECK = 0 RETURN END IF * RETURN END SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, ITYPE, LDA, LDB, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZHEGST reduces a complex Hermitian-definite generalized * eigenproblem to standard form. * * If ITYPE = 1, the problem is A*x = lambda*B*x, * and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) * * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or * B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. * * B must have been previously factorized as U**H*U or L*L**H by ZPOTRF. * * Arguments * ========= * * ITYPE (input) INTEGER * = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); * = 2 or 3: compute U*A*U**H or L**H*A*L. * * UPLO (input) CHARACTER * = 'U': Upper triangle of A is stored and B is factored as * U**H*U; * = 'L': Lower triangle of A is stored and B is factored as * L*L**H. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the transformed matrix, stored in the * same format as A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input) COMPLEX*16 array, dimension (LDB,N) * The triangular factor from the Cholesky factorization of B, * as returned by ZPOTRF. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CONE, HALF PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ HALF = ( 0.5D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER K, KB, NB * .. * .. External Subroutines .. EXTERNAL XERBLA, ZHEGS2, ZHEMM, ZHER2K, ZTRMM, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHEGST', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'ZHEGST', UPLO, N, -1, -1, -1 ) * IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code * CALL ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) ELSE * * Use blocked code * IF( ITYPE.EQ.1 ) THEN IF( UPPER ) THEN * * Compute inv(U')*A*inv(U) * DO 10 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the upper triangle of A(k:n,k:n) * CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) IF( K+KB.LE.N ) THEN CALL ZTRSM( 'Left', UPLO, 'Conjugate transpose', $ 'Non-unit', KB, N-K-KB+1, CONE, $ B( K, K ), LDB, A( K, K+KB ), LDA ) CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, $ A( K, K ), LDA, B( K, K+KB ), LDB, $ CONE, A( K, K+KB ), LDA ) CALL ZHER2K( UPLO, 'Conjugate transpose', N-K-KB+1, $ KB, -CONE, A( K, K+KB ), LDA, $ B( K, K+KB ), LDB, ONE, $ A( K+KB, K+KB ), LDA ) CALL ZHEMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, $ A( K, K ), LDA, B( K, K+KB ), LDB, $ CONE, A( K, K+KB ), LDA ) CALL ZTRSM( 'Right', UPLO, 'No transpose', $ 'Non-unit', KB, N-K-KB+1, CONE, $ B( K+KB, K+KB ), LDB, A( K, K+KB ), $ LDA ) END IF 10 CONTINUE ELSE * * Compute inv(L)*A*inv(L') * DO 20 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the lower triangle of A(k:n,k:n) * CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) IF( K+KB.LE.N ) THEN CALL ZTRSM( 'Right', UPLO, 'Conjugate transpose', $ 'Non-unit', N-K-KB+1, KB, CONE, $ B( K, K ), LDB, A( K+KB, K ), LDA ) CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, $ A( K, K ), LDA, B( K+KB, K ), LDB, $ CONE, A( K+KB, K ), LDA ) CALL ZHER2K( UPLO, 'No transpose', N-K-KB+1, KB, $ -CONE, A( K+KB, K ), LDA, $ B( K+KB, K ), LDB, ONE, $ A( K+KB, K+KB ), LDA ) CALL ZHEMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, $ A( K, K ), LDA, B( K+KB, K ), LDB, $ CONE, A( K+KB, K ), LDA ) CALL ZTRSM( 'Left', UPLO, 'No transpose', $ 'Non-unit', N-K-KB+1, KB, CONE, $ B( K+KB, K+KB ), LDB, A( K+KB, K ), $ LDA ) END IF 20 CONTINUE END IF ELSE IF( UPPER ) THEN * * Compute U*A*U' * DO 30 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the upper triangle of A(1:k+kb-1,1:k+kb-1) * CALL ZTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', $ K-1, KB, CONE, B, LDB, A( 1, K ), LDA ) CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), $ LDA, B( 1, K ), LDB, CONE, A( 1, K ), $ LDA ) CALL ZHER2K( UPLO, 'No transpose', K-1, KB, CONE, $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, $ LDA ) CALL ZHEMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), $ LDA, B( 1, K ), LDB, CONE, A( 1, K ), $ LDA ) CALL ZTRMM( 'Right', UPLO, 'Conjugate transpose', $ 'Non-unit', K-1, KB, CONE, B( K, K ), LDB, $ A( 1, K ), LDA ) CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) 30 CONTINUE ELSE * * Compute L'*A*L * DO 40 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the lower triangle of A(1:k+kb-1,1:k+kb-1) * CALL ZTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', $ KB, K-1, CONE, B, LDB, A( K, 1 ), LDA ) CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), $ LDA, B( K, 1 ), LDB, CONE, A( K, 1 ), $ LDA ) CALL ZHER2K( UPLO, 'Conjugate transpose', K-1, KB, $ CONE, A( K, 1 ), LDA, B( K, 1 ), LDB, $ ONE, A, LDA ) CALL ZHEMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), $ LDA, B( K, 1 ), LDB, CONE, A( K, 1 ), $ LDA ) CALL ZTRMM( 'Left', UPLO, 'Conjugate transpose', $ 'Non-unit', KB, K-1, CONE, B( K, K ), LDB, $ A( K, 1 ), LDA ) CALL ZHEGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) 40 CONTINUE END IF END IF END IF RETURN * * End of ZHEGST * END SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ), W( * ) COMPLEX*16 A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * ZHEEV computes all eigenvalues and, optionally, eigenvectors of a * complex Hermitian matrix A. * * Arguments * ========= * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) * On entry, the Hermitian matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * On exit, if JOBZ = 'V', then if INFO = 0, A contains the * orthonormal eigenvectors of the matrix A. * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') * or the upper triangle (if UPLO='U') of A, including the * diagonal, is destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,2*N-1). * For optimal efficiency, LWORK >= (NB+1)*N, * where NB is the blocksize for ZHETRD returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, the algorithm failed to converge; i * off-diagonal elements of an intermediate tridiagonal * form did not converge to zero. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, $ LLWORK, LOPT, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANHE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE * .. * .. External Subroutines .. EXTERNAL DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR, $ ZUNGTR * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+1 )*N ) WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHEEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) WORK( 1 ) = 3 IF( WANTZ ) $ A( 1, 1 ) = CONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) $ CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) * * Call ZHETRD to reduce Hermitian matrix to tridiagonal form. * INDE = 1 INDTAU = 1 INDWRK = INDTAU + N LLWORK = LWORK - INDWRK + 1 CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) LOPT = N + WORK( INDWRK ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * ZUNGTR to generate the unitary matrix, then call ZSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, RWORK( INDE ), INFO ) ELSE CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), $ LLWORK, IINFO ) INDWRK = INDE + N CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA, $ RWORK( INDWRK ), INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * Set WORK(1) to optimal complex workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of ZHEEV * END SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, $ IWORK, IFAIL, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION RWORK( * ), W( * ) COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * ZHEEVX computes selected eigenvalues and, optionally, eigenvectors * of a complex Hermitian matrix A. Eigenvalues and eigenvectors can * be selected by specifying either a range of values or a range of * indices for the desired eigenvalues. * * Arguments * ========= * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * RANGE (input) CHARACTER*1 * = 'A': all eigenvalues will be found. * = 'V': all eigenvalues in the half-open interval (VL,VU] * will be found. * = 'I': the IL-th through IU-th eigenvalues will be found. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) * On entry, the Hermitian matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * On exit, the lower triangle (if UPLO='L') or the upper * triangle (if UPLO='U') of A, including the diagonal, is * destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * VL (input) DOUBLE PRECISION * VU (input) DOUBLE PRECISION * If RANGE='V', the lower and upper bounds of the interval to * be searched for eigenvalues. VL < VU. * Not referenced if RANGE = 'A' or 'I'. * * IL (input) INTEGER * IU (input) INTEGER * If RANGE='I', the indices (in ascending order) of the * smallest and largest eigenvalues to be returned. * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. * Not referenced if RANGE = 'A' or 'V'. * * ABSTOL (input) DOUBLE PRECISION * The absolute error tolerance for the eigenvalues. * An approximate eigenvalue is accepted as converged * when it is determined to lie in an interval [a,b] * of width less than or equal to * * ABSTOL + EPS * max( |a|,|b| ) , * * where EPS is the machine precision. If ABSTOL is less than * or equal to zero, then EPS*|T| will be used in its place, * where |T| is the 1-norm of the tridiagonal matrix obtained * by reducing A to tridiagonal form. * * Eigenvalues will be computed most accurately when ABSTOL is * set to twice the underflow threshold 2*DLAMCH('S'), not zero. * If this routine returns with INFO>0, indicating that some * eigenvectors did not converge, try setting ABSTOL to * 2*DLAMCH('S'). * * See "Computing Small Singular Values of Bidiagonal Matrices * with Guaranteed High Relative Accuracy," by Demmel and * Kahan, LAPACK Working Note #3. * * M (output) INTEGER * The total number of eigenvalues found. 0 <= M <= N. * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. * * W (output) DOUBLE PRECISION array, dimension (N) * On normal exit, the first M elements contain the selected * eigenvalues in ascending order. * * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) * If JOBZ = 'V', then if INFO = 0, the first M columns of Z * contain the orthonormal eigenvectors of the matrix A * corresponding to the selected eigenvalues, with the i-th * column of Z holding the eigenvector associated with W(i). * If an eigenvector fails to converge, then that column of Z * contains the latest approximation to the eigenvector, and the * index of the eigenvector is returned in IFAIL. * If JOBZ = 'N', then Z is not referenced. * Note: the user must ensure that at least max(1,M) columns are * supplied in the array Z; if RANGE = 'V', the exact value of M * is not known in advance and an upper bound must be used. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * JOBZ = 'V', LDZ >= max(1,N). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,2*N-1). * For optimal efficiency, LWORK >= (NB+1)*N, * where NB is the max of the blocksize for ZHETRD and for * ZUNMTR as returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) * * IWORK (workspace) INTEGER array, dimension (5*N) * * IFAIL (output) INTEGER array, dimension (N) * If JOBZ = 'V', then if INFO = 0, the first M elements of * IFAIL are zero. If INFO > 0, then IFAIL contains the * indices of the eigenvectors that failed to converge. * If JOBZ = 'N', then IFAIL is not referenced. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, then i eigenvectors failed to converge. * Their indices are stored in array IFAIL. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ CHARACTER ORDER INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LOPT, LWKOPT, NB, NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, $ SIGMA, SMLNUM, TMP1, VLL, VUU * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANHE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE * .. * .. External Subroutines .. EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, $ ZHETRD, ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR, $ ZUNMTR * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * LOWER = LSAME( UPLO, 'L' ) WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -8 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -10 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -15 ELSE IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -17 END IF END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) ) LWKOPT = ( NB+1 )*N WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHEEVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN WORK( 1 ) = 1 IF( ALLEIG .OR. INDEIG ) THEN M = 1 W( 1 ) = A( 1, 1 ) ELSE IF( VALEIG ) THEN IF( VL.LT.DBLE( A( 1, 1 ) ) .AND. VU.GE.DBLE( A( 1, 1 ) ) ) $ THEN M = 1 W( 1 ) = A( 1, 1 ) END IF END IF IF( WANTZ ) $ Z( 1, 1 ) = CONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 ABSTLL = ABSTOL VLL = VL VUU = VU ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK ) IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN DO 10 J = 1, N CALL ZDSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 10 CONTINUE ELSE DO 20 J = 1, N CALL ZDSCAL( J, SIGMA, A( 1, J ), 1 ) 20 CONTINUE END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA IF( VALEIG ) THEN VLL = VL*SIGMA VUU = VU*SIGMA END IF END IF * * Call ZHETRD to reduce Hermitian matrix to tridiagonal form. * INDD = 1 INDE = INDD + N INDRWK = INDE + N INDTAU = 1 INDWRK = INDTAU + N LLWORK = LWORK - INDWRK + 1 CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDD ), RWORK( INDE ), $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) LOPT = N + WORK( INDWRK ) * * If all eigenvalues are desired and ABSTOL is less than or equal to * zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for * some eigenvalue, then try DSTEBZ. * IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. $ ( ABSTOL.LE.ZERO ) ) THEN CALL DCOPY( N, RWORK( INDD ), 1, W, 1 ) INDEE = INDRWK + 2*N IF( .NOT.WANTZ ) THEN CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) CALL DSTERF( N, W, RWORK( INDEE ), INFO ) ELSE CALL ZLACPY( 'A', N, N, A, LDA, Z, LDZ ) CALL ZUNGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) CALL DCOPY( N-1, RWORK( INDE ), 1, RWORK( INDEE ), 1 ) CALL ZSTEQR( JOBZ, N, W, RWORK( INDEE ), Z, LDZ, $ RWORK( INDRWK ), INFO ) IF( INFO.EQ.0 ) THEN DO 30 I = 1, N IFAIL( I ) = 0 30 CONTINUE END IF END IF IF( INFO.EQ.0 ) THEN M = N GO TO 40 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF INDIBL = 1 INDISP = INDIBL + N INDIWK = INDISP + N CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, $ RWORK( INDD ), RWORK( INDE ), M, NSPLIT, W, $ IWORK( INDIBL ), IWORK( INDISP ), RWORK( INDRWK ), $ IWORK( INDIWK ), INFO ) * IF( WANTZ ) THEN CALL ZSTEIN( N, RWORK( INDD ), RWORK( INDE ), M, W, $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, $ RWORK( INDRWK ), IWORK( INDIWK ), IFAIL, INFO ) * * Apply unitary matrix used in reduction to tridiagonal * form to eigenvectors returned by ZSTEIN. * CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = M ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * If eigenvalues are not in order, then sort them, along with * eigenvectors. * IF( WANTZ ) THEN DO 60 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 50 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 50 CONTINUE * IF( I.NE.0 ) THEN ITMP1 = IWORK( INDIBL+I-1 ) W( I ) = W( J ) IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) W( J ) = TMP1 IWORK( INDIBL+J-1 ) = ITMP1 CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) IF( INFO.NE.0 ) THEN ITMP1 = IFAIL( I ) IFAIL( I ) = IFAIL( J ) IFAIL( J ) = ITMP1 END IF END IF 60 CONTINUE END IF * * Set WORK(1) to optimal complex workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of ZHEEVX * END SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, KB, LDA, LDW, N, NB * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), W( LDW, * ) * .. * * Purpose * ======= * * DLASYF computes a partial factorization of a real symmetric matrix A * using the Bunch-Kaufman diagonal pivoting method. The partial * factorization has the form: * * A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: * ( 0 U22 ) ( 0 D ) ( U12' U22' ) * * A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L' * ( L21 I ) ( 0 A22 ) ( 0 I ) * * where the order of D is at most NB. The actual order is returned in * the argument KB, and is either NB or NB-1, or N if N <= NB. * * DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code * (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or * A22 (if UPLO = 'L'). * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored: * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NB (input) INTEGER * The maximum number of columns of the matrix A that should be * factored. NB should be at least 2 to allow for 2-by-2 pivot * blocks. * * KB (output) INTEGER * The number of columns of A that were actually factored. * KB is either NB-1 or NB, or N if N <= NB. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * n-by-n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n-by-n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit, A contains details of the partial factorization. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (output) INTEGER array, dimension (N) * Details of the interchanges and the block structure of D. * If UPLO = 'U', only the last KB elements of IPIV are set; * if UPLO = 'L', only the first KB elements are set. * * If IPIV(k) > 0, then rows and columns k and IPIV(k) were * interchanged and D(k,k) is a 1-by-1 diagonal block. * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. * * W (workspace) DOUBLE PRECISION array, dimension (LDW,NB) * * LDW (input) INTEGER * The leading dimension of the array W. LDW >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * > 0: if INFO = k, D(k,k) is exactly zero. The factorization * has been completed, but the block diagonal matrix D is * exactly singular. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, $ KSTEP, KW DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, $ ROWMAX, T * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX EXTERNAL LSAME, IDAMAX * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT * IF( LSAME( UPLO, 'U' ) ) THEN * * Factorize the trailing columns of A using the upper triangle * of A and working backwards, and compute the matrix W = U12*D * for use in updating A11 * * K is the main loop index, decreasing from N in steps of 1 or 2 * * KW is the column of W which corresponds to column K of A * K = N 10 CONTINUE KW = NB + K - N * * Exit from loop * IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) $ GO TO 30 * * Copy column K of A to column KW of W and update it * CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) IF( K.LT.N ) $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA, $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) * KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( W( K, KW ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) COLMAX = ABS( W( IMAX, KW ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * Copy column IMAX to column KW-1 of W and update it * CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, $ W( IMAX+1, KW-1 ), 1 ) IF( K.LT.N ) $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), $ LDA, W( IMAX, KW+1 ), LDW, ONE, $ W( 1, KW-1 ), 1 ) * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) ROWMAX = ABS( W( JMAX, KW-1 ) ) IF( IMAX.GT.1 ) THEN JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX * * copy column KW-1 of W to column KW * CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K - KSTEP + 1 KKW = NB + KK - N * * Updated column KP is already stored in column KKW of W * IF( KP.NE.KK ) THEN * * Copy non-updated column KK to column KP * A( KP, K ) = A( KK, K ) CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) * * Interchange rows KK and KP in last KK columns of A and W * CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), $ LDW ) END IF * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column KW of W now holds * * W(k) = U(k)*D(k) * * where U(k) is the k-th column of U * * Store U(k) in column k of A * CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) R1 = ONE / A( K, K ) CALL DSCAL( K-1, R1, A( 1, K ), 1 ) ELSE * * 2-by-2 pivot block D(k): columns KW and KW-1 of W now * hold * * ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U * IF( K.GT.2 ) THEN * * Store U(k) and U(k-1) in columns k and k-1 of A * D21 = W( K-1, KW ) D11 = W( K, KW ) / D21 D22 = W( K-1, KW-1 ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 DO 20 J = 1, K - 2 A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) 20 CONTINUE END IF * * Copy D(k) to A * A( K-1, K-1 ) = W( K-1, KW-1 ) A( K-1, K ) = W( K-1, KW ) A( K, K ) = W( K, KW ) END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF * * Decrease K and return to the start of the main loop * K = K - KSTEP GO TO 10 * 30 CONTINUE * * Update the upper triangle of A11 (= A(1:k,1:k)) as * * A11 := A11 - U12*D*U12' = A11 - U12*W' * * computing blocks of NB columns at a time * DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB JB = MIN( NB, K-J+1 ) * * Update the upper triangle of the diagonal block * DO 40 JJ = J, J + JB - 1 CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE, $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, $ A( J, JJ ), 1 ) 40 CONTINUE * * Update the rectangular superdiagonal block * CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE, $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, $ A( 1, J ), LDA ) 50 CONTINUE * * Put U12 in standard form by partially undoing the interchanges * in columns k+1:n * J = K + 1 60 CONTINUE JJ = J JP = IPIV( J ) IF( JP.LT.0 ) THEN JP = -JP J = J + 1 END IF J = J + 1 IF( JP.NE.JJ .AND. J.LE.N ) $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) IF( J.LE.N ) $ GO TO 60 * * Set KB to the number of columns factorized * KB = N - K * ELSE * * Factorize the leading columns of A using the lower triangle * of A and working forwards, and compute the matrix W = L21*D * for use in updating A22 * * K is the main loop index, increasing from 1 in steps of 1 or 2 * K = 1 70 CONTINUE * * Exit from loop * IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) $ GO TO 90 * * Copy column K of A to column K of W and update it * CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA, $ W( K, 1 ), LDW, ONE, W( K, K ), 1 ) * KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( W( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) COLMAX = ABS( W( IMAX, K ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * Copy column IMAX to column K+1 of W and update it * CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), $ 1 ) CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) ROWMAX = ABS( W( JMAX, K+1 ) ) IF( IMAX.LT.N ) THEN JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 ) ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX * * copy column K+1 of W to column K * CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K + KSTEP - 1 * * Updated column KP is already stored in column KK of W * IF( KP.NE.KK ) THEN * * Copy non-updated column KK to column KP * A( KP, K ) = A( KK, K ) CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) * * Interchange rows KK and KP in first KK columns of A and W * CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) END IF * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k of W now holds * * W(k) = L(k)*D(k) * * where L(k) is the k-th column of L * * Store L(k) in column k of A * CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) IF( K.LT.N ) THEN R1 = ONE / A( K, K ) CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) END IF ELSE * * 2-by-2 pivot block D(k): columns k and k+1 of W now hold * * ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) * * where L(k) and L(k+1) are the k-th and (k+1)-th columns * of L * IF( K.LT.N-1 ) THEN * * Store L(k) and L(k+1) in columns k and k+1 of A * D21 = W( K+1, K ) D11 = W( K+1, K+1 ) / D21 D22 = W( K, K ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 DO 80 J = K + 2, N A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) 80 CONTINUE END IF * * Copy D(k) to A * A( K, K ) = W( K, K ) A( K+1, K ) = W( K+1, K ) A( K+1, K+1 ) = W( K+1, K+1 ) END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF * * Increase K and return to the start of the main loop * K = K + KSTEP GO TO 70 * 90 CONTINUE * * Update the lower triangle of A22 (= A(k:n,k:n)) as * * A22 := A22 - L21*D*L21' = A22 - L21*W' * * computing blocks of NB columns at a time * DO 110 J = K, N, NB JB = MIN( NB, N-J+1 ) * * Update the lower triangle of the diagonal block * DO 100 JJ = J, J + JB - 1 CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE, $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, $ A( JJ, JJ ), 1 ) 100 CONTINUE * * Update the rectangular subdiagonal block * IF( J+JB.LE.N ) $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, $ ONE, A( J+JB, J ), LDA ) 110 CONTINUE * * Put L21 in standard form by partially undoing the interchanges * in columns 1:k-1 * J = K - 1 120 CONTINUE JJ = J JP = IPIV( J ) IF( JP.LT.0 ) THEN JP = -JP J = J - 1 END IF J = J - 1 IF( JP.NE.JJ .AND. J.GE.1 ) $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) IF( J.GE.1 ) $ GO TO 120 * * Set KB to the number of columns factorized * KB = K - 1 * END IF RETURN * * End of DLASYF * END SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DSYTF2 computes the factorization of a real symmetric matrix A using * the Bunch-Kaufman diagonal pivoting method: * * A = U*D*U' or A = L*D*L' * * where U (or L) is a product of permutation and unit upper (lower) * triangular matrices, U' is the transpose of U, and D is symmetric and * block diagonal with 1-by-1 and 2-by-2 diagonal blocks. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored: * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * n-by-n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n-by-n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, the block diagonal matrix D and the multipliers used * to obtain the factor U or L (see below for further details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (output) INTEGER array, dimension (N) * Details of the interchanges and the block structure of D. * If IPIV(k) > 0, then rows and columns k and IPIV(k) were * interchanged and D(k,k) is a 1-by-1 diagonal block. * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, D(k,k) is exactly zero. The factorization * has been completed, but the block diagonal matrix D is * exactly singular, and division by zero will occur if it * is used to solve a system of equations. * * Further Details * =============== * * 1-96 - Based on modifications by J. Lewis, Boeing Computer Services * Company * * If UPLO = 'U', then A = U*D*U', where * U = P(n)*U(n)* ... *P(k)U(k)* ..., * i.e., U is a product of terms P(k)*U(k), where k decreases from n to * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such * that if the diagonal block D(k) is of order s (s = 1 or 2), then * * ( I v 0 ) k-s * U(k) = ( 0 I 0 ) s * ( 0 0 I ) n-k * k-s s n-k * * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), * and A(k,k), and v overwrites A(1:k-2,k-1:k). * * If UPLO = 'L', then A = L*D*L', where * L = P(1)*L(1)* ... *P(k)*L(k)* ..., * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such * that if the diagonal block D(k) is of order s (s = 1 or 2), then * * ( I 0 0 ) k-1 * L(k) = ( 0 I 0 ) s * ( 0 v I ) n-k-s+1 * k-1 s n-k-s+1 * * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION EIGHT, SEVTEN PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, $ ROWMAX, T, WK, WKM1, WKP1 * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX EXTERNAL LSAME, IDAMAX * .. * .. External Subroutines .. EXTERNAL DSCAL, DSWAP, DSYR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTF2', -INFO ) RETURN END IF * * Initialize ALPHA for use in choosing pivot block size. * ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT * IF( UPPER ) THEN * * Factorize A as U*D*U' using the upper triangle of A * * K is the main loop index, decreasing from N to 1 in steps of * 1 or 2 * K = N 10 CONTINUE * * If K < 1, exit from loop * IF( K.LT.1 ) $ GO TO 70 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.GT.1 ) THEN IMAX = IDAMAX( K-1, A( 1, K ), 1 ) COLMAX = ABS( A( IMAX, K ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) IF( IMAX.GT.1 ) THEN JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K-1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K - KSTEP + 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the leading * submatrix A(1:k,1:k) * CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) A( KP, KP ) = T IF( KSTEP.EQ.2 ) THEN T = A( K-1, K ) A( K-1, K ) = A( KP, K ) A( KP, K ) = T END IF END IF * * Update the leading submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = U(k)*D(k) * * where U(k) is the k-th column of U * * Perform a rank-1 update of A(1:k-1,1:k-1) as * * A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' * R1 = ONE / A( K, K ) CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) * * Store U(k) in column k * CALL DSCAL( K-1, R1, A( 1, K ), 1 ) ELSE * * 2-by-2 pivot block D(k): columns k and k-1 now hold * * ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) * * where U(k) and U(k-1) are the k-th and (k-1)-th columns * of U * * Perform a rank-2 update of A(1:k-2,1:k-2) as * * A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' * = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' * IF( K.GT.2 ) THEN * D12 = A( K-1, K ) D22 = A( K-1, K-1 ) / D12 D11 = A( K, K ) / D12 T = ONE / ( D11*D22-ONE ) D12 = T / D12 * DO 30 J = K - 2, 1, -1 WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) ) WK = D12*( D22*A( J, K )-A( J, K-1 ) ) DO 20 I = J, 1, -1 A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K-1 )*WKM1 20 CONTINUE A( J, K ) = WK A( J, K-1 ) = WKM1 30 CONTINUE * END IF * END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K-1 ) = -KP END IF * * Decrease K and return to the start of the main loop * K = K - KSTEP GO TO 10 * ELSE * * Factorize A as L*D*L' using the lower triangle of A * * K is the main loop index, increasing from 1 to N in steps of * 1 or 2 * K = 1 40 CONTINUE * * If K > N, exit from loop * IF( K.GT.N ) $ GO TO 70 KSTEP = 1 * * Determine rows and columns to be interchanged and whether * a 1-by-1 or 2-by-2 pivot block will be used * ABSAKK = ABS( A( K, K ) ) * * IMAX is the row-index of the largest off-diagonal element in * column K, and COLMAX is its absolute value * IF( K.LT.N ) THEN IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) COLMAX = ABS( A( IMAX, K ) ) ELSE COLMAX = ZERO END IF * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN * * Column K is zero: set INFO and continue * IF( INFO.EQ.0 ) $ INFO = K KP = K ELSE IF( ABSAKK.GE.ALPHA*COLMAX ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE * * JMAX is the column-index of the largest off-diagonal * element in row IMAX, and ROWMAX is its absolute value * JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) ROWMAX = ABS( A( IMAX, JMAX ) ) IF( IMAX.LT.N ) THEN JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) END IF * IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN * * no interchange, use 1-by-1 pivot block * KP = K ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN * * interchange rows and columns K and IMAX, use 1-by-1 * pivot block * KP = IMAX ELSE * * interchange rows and columns K+1 and IMAX, use 2-by-2 * pivot block * KP = IMAX KSTEP = 2 END IF END IF * KK = K + KSTEP - 1 IF( KP.NE.KK ) THEN * * Interchange rows and columns KK and KP in the trailing * submatrix A(k:n,k:n) * IF( KP.LT.N ) $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), $ LDA ) T = A( KK, KK ) A( KK, KK ) = A( KP, KP ) A( KP, KP ) = T IF( KSTEP.EQ.2 ) THEN T = A( K+1, K ) A( K+1, K ) = A( KP, K ) A( KP, K ) = T END IF END IF * * Update the trailing submatrix * IF( KSTEP.EQ.1 ) THEN * * 1-by-1 pivot block D(k): column k now holds * * W(k) = L(k)*D(k) * * where L(k) is the k-th column of L * IF( K.LT.N ) THEN * * Perform a rank-1 update of A(k+1:n,k+1:n) as * * A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' * D11 = ONE / A( K, K ) CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1, $ A( K+1, K+1 ), LDA ) * * Store L(k) in column K * CALL DSCAL( N-K, D11, A( K+1, K ), 1 ) END IF ELSE * * 2-by-2 pivot block D(k) * IF( K.LT.N-1 ) THEN * * Perform a rank-2 update of A(k+2:n,k+2:n) as * * A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))' * * where L(k) and L(k+1) are the k-th and (k+1)-th * columns of L * D21 = A( K+1, K ) D11 = A( K+1, K+1 ) / D21 D22 = A( K, K ) / D21 T = ONE / ( D11*D22-ONE ) D21 = T / D21 * DO 60 J = K + 2, N * WK = D21*( D11*A( J, K )-A( J, K+1 ) ) WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) ) * DO 50 I = J, N A( I, J ) = A( I, J ) - A( I, K )*WK - $ A( I, K+1 )*WKP1 50 CONTINUE * A( J, K ) = WK A( J, K+1 ) = WKP1 * 60 CONTINUE END IF END IF END IF * * Store details of the interchanges in IPIV * IF( KSTEP.EQ.1 ) THEN IPIV( K ) = KP ELSE IPIV( K ) = -KP IPIV( K+1 ) = -KP END IF * * Increase K and return to the start of the main loop * K = K + KSTEP GO TO 40 * END IF * 70 CONTINUE * RETURN * * End of DSYTF2 * END SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, ITYPE, LDA, LDB, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZHEGS2 reduces a complex Hermitian-definite generalized * eigenproblem to standard form. * * If ITYPE = 1, the problem is A*x = lambda*B*x, * and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') * * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or * B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. * * B must have been previously factorized as U'*U or L*L' by ZPOTRF. * * Arguments * ========= * * ITYPE (input) INTEGER * = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); * = 2 or 3: compute U*A*U' or L'*A*L. * * UPLO (input) CHARACTER * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored, and how B has been factorized. * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * n by n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n by n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the transformed matrix, stored in the * same format as A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input) COMPLEX*16 array, dimension (LDB,N) * The triangular factor from the Cholesky factorization of B, * as returned by ZPOTRF. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, HALF PARAMETER ( ONE = 1.0D+0, HALF = 0.5D+0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER K DOUBLE PRECISION AKK, BKK COMPLEX*16 CT * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZDSCAL, ZHER2, ZLACGV, ZTRMV, $ ZTRSV * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHEGS2', -INFO ) RETURN END IF * IF( ITYPE.EQ.1 ) THEN IF( UPPER ) THEN * * Compute inv(U')*A*inv(U) * DO 10 K = 1, N * * Update the upper triangle of A(k:n,k:n) * AKK = A( K, K ) BKK = B( K, K ) AKK = AKK / BKK**2 A( K, K ) = AKK IF( K.LT.N ) THEN CALL ZDSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) CT = -HALF*AKK CALL ZLACGV( N-K, A( K, K+1 ), LDA ) CALL ZLACGV( N-K, B( K, K+1 ), LDB ) CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), $ LDA ) CALL ZHER2( UPLO, N-K, -CONE, A( K, K+1 ), LDA, $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) CALL ZAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), $ LDA ) CALL ZLACGV( N-K, B( K, K+1 ), LDB ) CALL ZTRSV( UPLO, 'Conjugate transpose', 'Non-unit', $ N-K, B( K+1, K+1 ), LDB, A( K, K+1 ), $ LDA ) CALL ZLACGV( N-K, A( K, K+1 ), LDA ) END IF 10 CONTINUE ELSE * * Compute inv(L)*A*inv(L') * DO 20 K = 1, N * * Update the lower triangle of A(k:n,k:n) * AKK = A( K, K ) BKK = B( K, K ) AKK = AKK / BKK**2 A( K, K ) = AKK IF( K.LT.N ) THEN CALL ZDSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) CT = -HALF*AKK CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) CALL ZHER2( UPLO, N-K, -CONE, A( K+1, K ), 1, $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) CALL ZAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) CALL ZTRSV( UPLO, 'No transpose', 'Non-unit', N-K, $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) END IF 20 CONTINUE END IF ELSE IF( UPPER ) THEN * * Compute U*A*U' * DO 30 K = 1, N * * Update the upper triangle of A(1:k,1:k) * AKK = A( K, K ) BKK = B( K, K ) CALL ZTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, $ LDB, A( 1, K ), 1 ) CT = HALF*AKK CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) CALL ZHER2( UPLO, K-1, CONE, A( 1, K ), 1, B( 1, K ), 1, $ A, LDA ) CALL ZAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) CALL ZDSCAL( K-1, BKK, A( 1, K ), 1 ) A( K, K ) = AKK*BKK**2 30 CONTINUE ELSE * * Compute L'*A*L * DO 40 K = 1, N * * Update the lower triangle of A(1:k,1:k) * AKK = A( K, K ) BKK = B( K, K ) CALL ZLACGV( K-1, A( K, 1 ), LDA ) CALL ZTRMV( UPLO, 'Conjugate transpose', 'Non-unit', K-1, $ B, LDB, A( K, 1 ), LDA ) CT = HALF*AKK CALL ZLACGV( K-1, B( K, 1 ), LDB ) CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) CALL ZHER2( UPLO, K-1, CONE, A( K, 1 ), LDA, B( K, 1 ), $ LDB, A, LDA ) CALL ZAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) CALL ZLACGV( K-1, B( K, 1 ), LDB ) CALL ZDSCAL( K-1, BKK, A( K, 1 ), LDA ) CALL ZLACGV( K-1, A( K, 1 ), LDA ) A( K, K ) = AKK*BKK**2 40 CONTINUE END IF END IF RETURN * * End of ZHEGS2 * END DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANHE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * complex hermitian matrix A. * * Description * =========== * * ZLANHE returns the value * * ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANHE as described * above. * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * hermitian matrix A is to be referenced. * = 'U': Upper triangular part of A is referenced * = 'L': Lower triangular part of A is referenced * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, ZLANHE is * set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The hermitian matrix A. If UPLO = 'U', the leading n by n * upper triangular part of A contains the upper triangular part * of the matrix A, and the strictly lower triangular part of A * is not referenced. If UPLO = 'L', the leading n by n lower * triangular part of A contains the lower triangular part of * the matrix A, and the strictly upper triangular part of A is * not referenced. Note that the imaginary parts of the diagonal * elements need not be set and are assumed to be zero. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, J - 1 VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) ) 20 CONTINUE ELSE DO 40 J = 1, N VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) ) DO 30 I = J + 1, N VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 30 CONTINUE 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * Find normI(A) ( = norm1(A), since A is hermitian). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 50 CONTINUE WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) ) 60 CONTINUE DO 70 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) ) DO 90 I = J + 1, N ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 90 CONTINUE VALUE = MAX( VALUE, SUM ) 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF SUM = 2*SUM DO 130 I = 1, N IF( DBLE( A( I, I ) ).NE.ZERO ) THEN ABSA = ABS( DBLE( A( I, I ) ) ) IF( SCALE.LT.ABSA ) THEN SUM = ONE + SUM*( SCALE / ABSA )**2 SCALE = ABSA ELSE SUM = SUM + ( ABSA / SCALE )**2 END IF END IF 130 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANHE = VALUE RETURN * * End of ZLANHE * END SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASCL multiplies the M by N complex matrix A by the real scalar * CTO/CFROM. This is done without over/underflow as long as the final * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that * A may be full, upper triangular, lower triangular, upper Hessenberg, * or banded. * * Arguments * ========= * * TYPE (input) CHARACTER*1 * TYPE indices the storage type of the input matrix. * = 'G': A is a full matrix. * = 'L': A is a lower triangular matrix. * = 'U': A is an upper triangular matrix. * = 'H': A is an upper Hessenberg matrix. * = 'B': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the lower * half stored. * = 'Q': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the upper * half stored. * = 'Z': A is a band matrix with lower bandwidth KL and upper * bandwidth KU. * * KL (input) INTEGER * The lower bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * KU (input) INTEGER * The upper bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * CFROM (input) DOUBLE PRECISION * CTO (input) DOUBLE PRECISION * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed * without over/underflow if the final result CTO*A(I,J)/CFROM * can be represented without over/underflow. CFROM must be * nonzero. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * INFO (output) INTEGER * 0 - successful exit * <0 - if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of ZLASCL * END SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZHETRD reduces a complex Hermitian matrix A to real symmetric * tridiagonal form T by a unitary similarity transformation: * Q**H * A * Q = T. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit, if UPLO = 'U', the diagonal and first superdiagonal * of A are overwritten by the corresponding elements of the * tridiagonal matrix T, and the elements above the first * superdiagonal, with the array TAU, represent the unitary * matrix Q as a product of elementary reflectors; if UPLO * = 'L', the diagonal and first subdiagonal of A are over- * written by the corresponding elements of the tridiagonal * matrix T, and the elements below the first subdiagonal, with * the array TAU, represent the unitary matrix Q as a product * of elementary reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * D (output) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the tridiagonal matrix T: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (N-1) * The off-diagonal elements of the tridiagonal matrix T: * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 1. * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n-1) . . . H(2) H(1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in * A(1:i-1,i+1), and tau in TAU(i). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(n-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), * and tau in TAU(i). * * The contents of A on exit are illustrated by the following examples * with n = 5: * * if UPLO = 'U': if UPLO = 'L': * * ( d e v2 v3 v4 ) ( d ) * ( d e v3 v4 ) ( e d ) * ( d e v4 ) ( v1 e d ) * ( d e ) ( v1 v2 e d ) * ( d ) ( v1 v2 v3 e d ) * * where d and e denote diagonal and off-diagonal elements of T, and vi * denotes an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZHER2K, ZHETD2, ZLATRD * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. * NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHETRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NX = N IWS = 1 IF( NB.GT.1 .AND. NB.LT.N ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code). * NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) ) IF( NX.LT.N ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code by setting NX = N. * NB = MAX( LWORK / LDWORK, 1 ) NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 ) IF( NB.LT.NBMIN ) $ NX = N END IF ELSE NX = N END IF ELSE NB = 1 END IF * IF( UPPER ) THEN * * Reduce the upper triangle of A. * Columns 1:kk are handled by the unblocked method. * KK = N - ( ( N-NX+NB-1 ) / NB )*NB DO 20 I = N - NB + 1, KK + 1, -NB * * Reduce columns i:i+nb-1 to tridiagonal form and form the * matrix W which is needed to update the unreduced part of * the matrix * CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, $ LDWORK ) * * Update the unreduced submatrix A(1:i-1,1:i-1), using an * update of the form: A := A - V*W' - W*V' * CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE, $ A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA ) * * Copy superdiagonal elements back into A, and diagonal * elements into D * DO 10 J = I, I + NB - 1 A( J-1, J ) = E( J-1 ) D( J ) = A( J, J ) 10 CONTINUE 20 CONTINUE * * Use unblocked code to reduce the last or only block * CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) ELSE * * Reduce the lower triangle of A * DO 40 I = 1, N - NX, NB * * Reduce columns i:i+nb-1 to tridiagonal form and form the * matrix W which is needed to update the unreduced part of * the matrix * CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), $ TAU( I ), WORK, LDWORK ) * * Update the unreduced submatrix A(i+nb:n,i+nb:n), using * an update of the form: A := A - V*W' - W*V' * CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE, $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, $ A( I+NB, I+NB ), LDA ) * * Copy subdiagonal elements back into A, and diagonal * elements into D * DO 30 J = I, I + NB - 1 A( J+1, J ) = E( J ) D( J ) = A( J, J ) 30 CONTINUE 40 CONTINUE * * Use unblocked code to reduce the last or only block * CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAU( I ), IINFO ) END IF * WORK( 1 ) = LWKOPT RETURN * * End of ZHETRD * END SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGTR generates a complex unitary matrix Q which is defined as the * product of n-1 elementary reflectors of order N, as returned by * ZHETRD: * * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), * * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A contains elementary reflectors * from ZHETRD; * = 'L': Lower triangle of A contains elementary reflectors * from ZHETRD. * * N (input) INTEGER * The order of the matrix Q. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the vectors which define the elementary reflectors, * as returned by ZHETRD. * On exit, the N-by-N unitary matrix Q. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= N. * * TAU (input) COMPLEX*16 array, dimension (N-1) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZHETRD. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= N-1. * For optimum performance LWORK >= (N-1)*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER I, IINFO, J, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGQL, ZUNGQR * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF * IF( INFO.EQ.0 ) THEN IF( UPPER ) THEN NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 ) ELSE NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 ) END IF LWKOPT = MAX( 1, N-1 )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGTR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( UPPER ) THEN * * Q was determined by a call to ZHETRD with UPLO = 'U' * * Shift the vectors which define the elementary reflectors one * column to the left, and set the last row and column of Q to * those of the unit matrix * DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 A( I, J ) = A( I, J+1 ) 10 CONTINUE A( N, J ) = ZERO 20 CONTINUE DO 30 I = 1, N - 1 A( I, N ) = ZERO 30 CONTINUE A( N, N ) = ONE * * Generate Q(1:n-1,1:n-1) * CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * Q was determined by a call to ZHETRD with UPLO = 'L'. * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first row and column of Q to * those of the unit matrix * DO 50 J = N, 2, -1 A( 1, J ) = ZERO DO 40 I = J + 1, N A( I, J ) = A( I, J-1 ) 40 CONTINUE 50 CONTINUE A( 1, 1 ) = ONE DO 60 I = 2, N A( I, 1 ) = ZERO 60 CONTINUE IF( N.GT.1 ) THEN * * Generate Q(2:n,2:n) * CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNGTR * END SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZLACPY copies all or part of a two-dimensional matrix A to another * matrix B. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be copied to B. * = 'U': Upper triangular part * = 'L': Lower triangular part * Otherwise: All of the matrix A * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The m by n matrix A. If UPLO = 'U', only the upper trapezium * is accessed; if UPLO = 'L', only the lower trapezium is * accessed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (output) COMPLEX*16 array, dimension (LDB,N) * On exit, B = A in the locations specified by UPLO. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE * ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF * RETURN * * End of ZLACPY * END SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, $ INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER ORDER, RANGE INTEGER IL, INFO, IU, M, N, NSPLIT DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) * .. * * Purpose * ======= * * DSTEBZ computes the eigenvalues of a symmetric tridiagonal * matrix T. The user may ask for all eigenvalues, all eigenvalues * in the half-open interval (VL, VU], or the IL-th through IU-th * eigenvalues. * * To avoid overflow, the matrix must be scaled so that its * largest element is no greater than overflow**(1/2) * * underflow**(1/4) in absolute value, and for greatest * accuracy, it should not be much smaller than that. * * See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal * Matrix", Report CS41, Computer Science Dept., Stanford * University, July 21, 1966. * * Arguments * ========= * * RANGE (input) CHARACTER * = 'A': ("All") all eigenvalues will be found. * = 'V': ("Value") all eigenvalues in the half-open interval * (VL, VU] will be found. * = 'I': ("Index") the IL-th through IU-th eigenvalues (of the * entire matrix) will be found. * * ORDER (input) CHARACTER * = 'B': ("By Block") the eigenvalues will be grouped by * split-off block (see IBLOCK, ISPLIT) and * ordered from smallest to largest within * the block. * = 'E': ("Entire matrix") * the eigenvalues for the entire matrix * will be ordered from smallest to * largest. * * N (input) INTEGER * The order of the tridiagonal matrix T. N >= 0. * * VL (input) DOUBLE PRECISION * VU (input) DOUBLE PRECISION * If RANGE='V', the lower and upper bounds of the interval to * be searched for eigenvalues. Eigenvalues less than or equal * to VL, or greater than VU, will not be returned. VL < VU. * Not referenced if RANGE = 'A' or 'I'. * * IL (input) INTEGER * IU (input) INTEGER * If RANGE='I', the indices (in ascending order) of the * smallest and largest eigenvalues to be returned. * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. * Not referenced if RANGE = 'A' or 'V'. * * ABSTOL (input) DOUBLE PRECISION * The absolute tolerance for the eigenvalues. An eigenvalue * (or cluster) is considered to be located if it has been * determined to lie in an interval whose width is ABSTOL or * less. If ABSTOL is less than or equal to zero, then ULP*|T| * will be used, where |T| means the 1-norm of T. * * Eigenvalues will be computed most accurately when ABSTOL is * set to twice the underflow threshold 2*DLAMCH('S'), not zero. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the tridiagonal matrix T. * * E (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) off-diagonal elements of the tridiagonal matrix T. * * M (output) INTEGER * The actual number of eigenvalues found. 0 <= M <= N. * (See also the description of INFO=2,3.) * * NSPLIT (output) INTEGER * The number of diagonal blocks in the matrix T. * 1 <= NSPLIT <= N. * * W (output) DOUBLE PRECISION array, dimension (N) * On exit, the first M elements of W will contain the * eigenvalues. (DSTEBZ may use the remaining N-M elements as * workspace.) * * IBLOCK (output) INTEGER array, dimension (N) * At each row/column j where E(j) is zero or small, the * matrix T is considered to split into a block diagonal * matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which * block (from 1 to the number of blocks) the eigenvalue W(i) * belongs. (DSTEBZ may use the remaining N-M elements as * workspace.) * * ISPLIT (output) INTEGER array, dimension (N) * The splitting points, at which T breaks up into submatrices. * The first submatrix consists of rows/columns 1 to ISPLIT(1), * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), * etc., and the NSPLIT-th consists of rows/columns * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. * (Only the first NSPLIT elements will actually be used, but * since the user cannot know a priori what value NSPLIT will * have, N words must be reserved for ISPLIT.) * * WORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * IWORK (workspace) INTEGER array, dimension (3*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: some or all of the eigenvalues failed to converge or * were not computed: * =1 or 3: Bisection failed to converge for some * eigenvalues; these eigenvalues are flagged by a * negative block number. The effect is that the * eigenvalues may not be as accurate as the * absolute and relative tolerances. This is * generally caused by unexpectedly inaccurate * arithmetic. * =2 or 3: RANGE='I' only: Not all of the eigenvalues * IL:IU were found. * Effect: M < IU+1-IL * Cause: non-monotonic arithmetic, causing the * Sturm sequence to be non-monotonic. * Cure: recalculate, using RANGE='A', and pick * out eigenvalues IL:IU. In some cases, * increasing the PARAMETER "FUDGE" may * make things work. * = 4: RANGE='I', and the Gershgorin interval * initially used was too small. No eigenvalues * were computed. * Probable cause: your machine has sloppy * floating-point arithmetic. * Cure: Increase the PARAMETER "FUDGE", * recompile, and try again. * * Internal Parameters * =================== * * RELFAC DOUBLE PRECISION, default = 2.0e0 * The relative tolerance. An interval (a,b] lies within * "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), * where "ulp" is the machine precision (distance from 1 to * the next larger floating point number.) * * FUDGE DOUBLE PRECISION, default = 2 * A "fudge factor" to widen the Gershgorin intervals. Ideally, * a value of 1 should work, but on machines with sloppy * arithmetic, this needs to be larger. The default for * publicly released versions should be large enough to handle * the worst machine around. Note that this has no effect * on accuracy of the solution. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, HALF PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ HALF = 1.0D0 / TWO ) DOUBLE PRECISION FUDGE, RELFAC PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 ) * .. * .. Local Scalars .. LOGICAL NCNVRG, TOOFEW INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, $ NWU DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL * .. * .. Local Arrays .. INTEGER IDUMMA( 1 ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL LSAME, ILAENV, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLAEBZ, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT * .. * .. Executable Statements .. * INFO = 0 * * Decode RANGE * IF( LSAME( RANGE, 'A' ) ) THEN IRANGE = 1 ELSE IF( LSAME( RANGE, 'V' ) ) THEN IRANGE = 2 ELSE IF( LSAME( RANGE, 'I' ) ) THEN IRANGE = 3 ELSE IRANGE = 0 END IF * * Decode ORDER * IF( LSAME( ORDER, 'B' ) ) THEN IORDER = 2 ELSE IF( LSAME( ORDER, 'E' ) ) THEN IORDER = 1 ELSE IORDER = 0 END IF * * Check for Errors * IF( IRANGE.LE.0 ) THEN INFO = -1 ELSE IF( IORDER.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( IRANGE.EQ.2 ) THEN IF( VL.GE.VU ) $ INFO = -5 ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) $ THEN INFO = -6 ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) $ THEN INFO = -7 END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEBZ', -INFO ) RETURN END IF * * Initialize error flags * INFO = 0 NCNVRG = .FALSE. TOOFEW = .FALSE. * * Quick return if possible * M = 0 IF( N.EQ.0 ) $ RETURN * * Simplifications: * IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) $ IRANGE = 1 * * Get machine constants * NB is the minimum vector length for vector bisection, or 0 * if only scalar is to be done. * SAFEMN = DLAMCH( 'S' ) ULP = DLAMCH( 'P' ) RTOLI = ULP*RELFAC NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) IF( NB.LE.1 ) $ NB = 0 * * Special Case when N=1 * IF( N.EQ.1 ) THEN NSPLIT = 1 ISPLIT( 1 ) = 1 IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN M = 0 ELSE W( 1 ) = D( 1 ) IBLOCK( 1 ) = 1 M = 1 END IF RETURN END IF * * Compute Splitting Points * NSPLIT = 1 WORK( N ) = ZERO PIVMIN = ONE * *DIR$ NOVECTOR DO 10 J = 2, N TMP1 = E( J-1 )**2 IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN ISPLIT( NSPLIT ) = J - 1 NSPLIT = NSPLIT + 1 WORK( J-1 ) = ZERO ELSE WORK( J-1 ) = TMP1 PIVMIN = MAX( PIVMIN, TMP1 ) END IF 10 CONTINUE ISPLIT( NSPLIT ) = N PIVMIN = PIVMIN*SAFEMN * * Compute Interval and ATOLI * IF( IRANGE.EQ.3 ) THEN * * RANGE='I': Compute the interval containing eigenvalues * IL through IU. * * Compute Gershgorin interval for entire (split) matrix * and use it as the initial interval * GU = D( 1 ) GL = D( 1 ) TMP1 = ZERO * DO 20 J = 1, N - 1 TMP2 = SQRT( WORK( J ) ) GU = MAX( GU, D( J )+TMP1+TMP2 ) GL = MIN( GL, D( J )-TMP1-TMP2 ) TMP1 = TMP2 20 CONTINUE * GU = MAX( GU, D( N )+TMP1 ) GL = MIN( GL, D( N )-TMP1 ) TNORM = MAX( ABS( GL ), ABS( GU ) ) GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN * * Compute Iteration parameters * ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 IF( ABSTOL.LE.ZERO ) THEN ATOLI = ULP*TNORM ELSE ATOLI = ABSTOL END IF * WORK( N+1 ) = GL WORK( N+2 ) = GL WORK( N+3 ) = GU WORK( N+4 ) = GU WORK( N+5 ) = GL WORK( N+6 ) = GU IWORK( 1 ) = -1 IWORK( 2 ) = -1 IWORK( 3 ) = N + 1 IWORK( 4 ) = N + 1 IWORK( 5 ) = IL - 1 IWORK( 6 ) = IU * CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, $ IWORK, W, IBLOCK, IINFO ) * IF( IWORK( 6 ).EQ.IU ) THEN WL = WORK( N+1 ) WLU = WORK( N+3 ) NWL = IWORK( 1 ) WU = WORK( N+4 ) WUL = WORK( N+2 ) NWU = IWORK( 4 ) ELSE WL = WORK( N+2 ) WLU = WORK( N+4 ) NWL = IWORK( 2 ) WU = WORK( N+3 ) WUL = WORK( N+1 ) NWU = IWORK( 3 ) END IF * IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN INFO = 4 RETURN END IF ELSE * * RANGE='A' or 'V' -- Set ATOLI * TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), $ ABS( D( N ) )+ABS( E( N-1 ) ) ) * DO 30 J = 2, N - 1 TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ $ ABS( E( J ) ) ) 30 CONTINUE * IF( ABSTOL.LE.ZERO ) THEN ATOLI = ULP*TNORM ELSE ATOLI = ABSTOL END IF * IF( IRANGE.EQ.2 ) THEN WL = VL WU = VU ELSE WL = ZERO WU = ZERO END IF END IF * * Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. * NWL accumulates the number of eigenvalues .le. WL, * NWU accumulates the number of eigenvalues .le. WU * M = 0 IEND = 0 INFO = 0 NWL = 0 NWU = 0 * DO 70 JB = 1, NSPLIT IOFF = IEND IBEGIN = IOFF + 1 IEND = ISPLIT( JB ) IN = IEND - IOFF * IF( IN.EQ.1 ) THEN * * Special Case -- IN=1 * IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) $ NWL = NWL + 1 IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) $ NWU = NWU + 1 IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. $ D( IBEGIN )-PIVMIN ) ) THEN M = M + 1 W( M ) = D( IBEGIN ) IBLOCK( M ) = JB END IF ELSE * * General Case -- IN > 1 * * Compute Gershgorin Interval * and use it as the initial interval * GU = D( IBEGIN ) GL = D( IBEGIN ) TMP1 = ZERO * DO 40 J = IBEGIN, IEND - 1 TMP2 = ABS( E( J ) ) GU = MAX( GU, D( J )+TMP1+TMP2 ) GL = MIN( GL, D( J )-TMP1-TMP2 ) TMP1 = TMP2 40 CONTINUE * GU = MAX( GU, D( IEND )+TMP1 ) GL = MIN( GL, D( IEND )-TMP1 ) BNORM = MAX( ABS( GL ), ABS( GU ) ) GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN * * Compute ATOLI for the current submatrix * IF( ABSTOL.LE.ZERO ) THEN ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) ) ELSE ATOLI = ABSTOL END IF * IF( IRANGE.GT.1 ) THEN IF( GU.LT.WL ) THEN NWL = NWL + IN NWU = NWU + IN GO TO 70 END IF GL = MAX( GL, WL ) GU = MIN( GU, WU ) IF( GL.GE.GU ) $ GO TO 70 END IF * * Set Up Initial Interval * WORK( N+1 ) = GL WORK( N+IN+1 ) = GU CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) * NWL = NWL + IWORK( 1 ) NWU = NWU + IWORK( IN+1 ) IWOFF = M - IWORK( 1 ) * * Compute Eigenvalues * ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / $ LOG( TWO ) ) + 2 CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) * * Copy Eigenvalues Into W and IBLOCK * Use -JB for block number for unconverged eigenvalues. * DO 60 J = 1, IOUT TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) * * Flag non-convergence. * IF( J.GT.IOUT-IINFO ) THEN NCNVRG = .TRUE. IB = -JB ELSE IB = JB END IF DO 50 JE = IWORK( J ) + 1 + IWOFF, $ IWORK( J+IN ) + IWOFF W( JE ) = TMP1 IBLOCK( JE ) = IB 50 CONTINUE 60 CONTINUE * M = M + IM END IF 70 CONTINUE * * If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU * If NWL+1 < IL or NWU > IU, discard extra eigenvalues. * IF( IRANGE.EQ.3 ) THEN IM = 0 IDISCL = IL - 1 - NWL IDISCU = NWU - IU * IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN DO 80 JE = 1, M IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN IDISCL = IDISCL - 1 ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN IDISCU = IDISCU - 1 ELSE IM = IM + 1 W( IM ) = W( JE ) IBLOCK( IM ) = IBLOCK( JE ) END IF 80 CONTINUE M = IM END IF IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN * * Code to deal with effects of bad arithmetic: * Some low eigenvalues to be discarded are not in (WL,WLU], * or high eigenvalues to be discarded are not in (WUL,WU] * so just kill off the smallest IDISCL/largest IDISCU * eigenvalues, by simply finding the smallest/largest * eigenvalue(s). * * (If N(w) is monotone non-decreasing, this should never * happen.) * IF( IDISCL.GT.0 ) THEN WKILL = WU DO 100 JDISC = 1, IDISCL IW = 0 DO 90 JE = 1, M IF( IBLOCK( JE ).NE.0 .AND. $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN IW = JE WKILL = W( JE ) END IF 90 CONTINUE IBLOCK( IW ) = 0 100 CONTINUE END IF IF( IDISCU.GT.0 ) THEN * WKILL = WL DO 120 JDISC = 1, IDISCU IW = 0 DO 110 JE = 1, M IF( IBLOCK( JE ).NE.0 .AND. $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN IW = JE WKILL = W( JE ) END IF 110 CONTINUE IBLOCK( IW ) = 0 120 CONTINUE END IF IM = 0 DO 130 JE = 1, M IF( IBLOCK( JE ).NE.0 ) THEN IM = IM + 1 W( IM ) = W( JE ) IBLOCK( IM ) = IBLOCK( JE ) END IF 130 CONTINUE M = IM END IF IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN TOOFEW = .TRUE. END IF END IF * * If ORDER='B', do nothing -- the eigenvalues are already sorted * by block. * If ORDER='E', sort the eigenvalues from smallest to largest * IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN DO 150 JE = 1, M - 1 IE = 0 TMP1 = W( JE ) DO 140 J = JE + 1, M IF( W( J ).LT.TMP1 ) THEN IE = J TMP1 = W( J ) END IF 140 CONTINUE * IF( IE.NE.0 ) THEN ITMP1 = IBLOCK( IE ) W( IE ) = W( JE ) IBLOCK( IE ) = IBLOCK( JE ) W( JE ) = TMP1 IBLOCK( JE ) = ITMP1 END IF 150 CONTINUE END IF * INFO = 0 IF( NCNVRG ) $ INFO = INFO + 1 IF( TOOFEW ) $ INFO = INFO + 2 RETURN * * End of DSTEBZ * END SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDZ, M, N * .. * .. Array Arguments .. INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), $ IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) COMPLEX*16 Z( LDZ, * ) * .. * * Purpose * ======= * * ZSTEIN computes the eigenvectors of a real symmetric tridiagonal * matrix T corresponding to specified eigenvalues, using inverse * iteration. * * The maximum number of iterations allowed for each eigenvector is * specified by an internal parameter MAXITS (currently set to 5). * * Although the eigenvectors are real, they are stored in a complex * array, which may be passed to ZUNMTR or ZUPMTR for back * transformation to the eigenvectors of a complex Hermitian matrix * which was reduced to tridiagonal form. * * * Arguments * ========= * * N (input) INTEGER * The order of the matrix. N >= 0. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the tridiagonal matrix T. * * E (input) DOUBLE PRECISION array, dimension (N) * The (n-1) subdiagonal elements of the tridiagonal matrix * T, stored in elements 1 to N-1; E(N) need not be set. * * M (input) INTEGER * The number of eigenvectors to be found. 0 <= M <= N. * * W (input) DOUBLE PRECISION array, dimension (N) * The first M elements of W contain the eigenvalues for * which eigenvectors are to be computed. The eigenvalues * should be grouped by split-off block and ordered from * smallest to largest within the block. ( The output array * W from DSTEBZ with ORDER = 'B' is expected here. ) * * IBLOCK (input) INTEGER array, dimension (N) * The submatrix indices associated with the corresponding * eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to * the first submatrix from the top, =2 if W(i) belongs to * the second submatrix, etc. ( The output array IBLOCK * from DSTEBZ is expected here. ) * * ISPLIT (input) INTEGER array, dimension (N) * The splitting points, at which T breaks up into submatrices. * The first submatrix consists of rows/columns 1 to * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 * through ISPLIT( 2 ), etc. * ( The output array ISPLIT from DSTEBZ is expected here. ) * * Z (output) COMPLEX*16 array, dimension (LDZ, M) * The computed eigenvectors. The eigenvector associated * with the eigenvalue W(i) is stored in the i-th column of * Z. Any vector which fails to converge is set to its current * iterate after MAXITS iterations. * The imaginary parts of the eigenvectors are set to zero. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * * WORK (workspace) DOUBLE PRECISION array, dimension (5*N) * * IWORK (workspace) INTEGER array, dimension (N) * * IFAIL (output) INTEGER array, dimension (M) * On normal exit, all elements of IFAIL are zero. * If one or more eigenvectors fail to converge after * MAXITS iterations, then their indices are stored in * array IFAIL. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, then i eigenvectors failed to converge * in MAXITS iterations. Their indices are stored in * array IFAIL. * * Internal Parameters * =================== * * MAXITS INTEGER, default = 5 * The maximum number of iterations performed. * * EXTRA INTEGER, default = 2 * The number of iterations performed after norm growth * criterion is satisfied, should be at least 1. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) INTEGER MAXITS, EXTRA PARAMETER ( MAXITS = 5, EXTRA = 2 ) * .. * .. Local Scalars .. INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, $ JBLK, JMAX, JR, NBLK, NRMCHK DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, $ SCL, SEP, TOL, XJ, XJM, ZTR * .. * .. Local Arrays .. INTEGER ISEED( 4 ) * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM, DLAMCH, DNRM2 EXTERNAL IDAMAX, DASUM, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 DO 10 I = 1, M IFAIL( I ) = 0 10 CONTINUE * IF( N.LT.0 ) THEN INFO = -1 ELSE IF( M.LT.0 .OR. M.GT.N ) THEN INFO = -4 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE DO 20 J = 2, M IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN INFO = -6 GO TO 30 END IF IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) $ THEN INFO = -5 GO TO 30 END IF 20 CONTINUE 30 CONTINUE END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZSTEIN', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) THEN RETURN ELSE IF( N.EQ.1 ) THEN Z( 1, 1 ) = CONE RETURN END IF * * Get machine constants. * EPS = DLAMCH( 'Precision' ) * * Initialize seed for random number generator DLARNV. * DO 40 I = 1, 4 ISEED( I ) = 1 40 CONTINUE * * Initialize pointers. * INDRV1 = 0 INDRV2 = INDRV1 + N INDRV3 = INDRV2 + N INDRV4 = INDRV3 + N INDRV5 = INDRV4 + N * * Compute eigenvectors of matrix blocks. * J1 = 1 DO 180 NBLK = 1, IBLOCK( M ) * * Find starting and ending indices of block nblk. * IF( NBLK.EQ.1 ) THEN B1 = 1 ELSE B1 = ISPLIT( NBLK-1 ) + 1 END IF BN = ISPLIT( NBLK ) BLKSIZ = BN - B1 + 1 IF( BLKSIZ.EQ.1 ) $ GO TO 60 GPIND = B1 * * Compute reorthogonalization criterion and stopping criterion. * ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) DO 50 I = B1 + 1, BN - 1 ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ $ ABS( E( I ) ) ) 50 CONTINUE ORTOL = ODM3*ONENRM * DTPCRT = SQRT( ODM1 / BLKSIZ ) * * Loop through eigenvalues of block nblk. * 60 CONTINUE JBLK = 0 DO 170 J = J1, M IF( IBLOCK( J ).NE.NBLK ) THEN J1 = J GO TO 180 END IF JBLK = JBLK + 1 XJ = W( J ) * * Skip all the work if the block size is one. * IF( BLKSIZ.EQ.1 ) THEN WORK( INDRV1+1 ) = ONE GO TO 140 END IF * * If eigenvalues j and j-1 are too close, add a relatively * small perturbation. * IF( JBLK.GT.1 ) THEN EPS1 = ABS( EPS*XJ ) PERTOL = TEN*EPS1 SEP = XJ - XJM IF( SEP.LT.PERTOL ) $ XJ = XJM + PERTOL END IF * ITS = 0 NRMCHK = 0 * * Get random starting vector. * CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) * * Copy the matrix T so it won't be destroyed in factorization. * CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) * * Compute LU factors with partial pivoting ( PT = LU ) * TOL = ZERO CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, $ IINFO ) * * Update iteration count. * 70 CONTINUE ITS = ITS + 1 IF( ITS.GT.MAXITS ) $ GO TO 120 * * Normalize and scale the righthand side vector Pb. * SCL = BLKSIZ*ONENRM*MAX( EPS, $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / $ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 ) CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) * * Solve the system LU = Pb. * CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, $ WORK( INDRV1+1 ), TOL, IINFO ) * * Reorthogonalize by modified Gram-Schmidt if eigenvalues are * close enough. * IF( JBLK.EQ.1 ) $ GO TO 110 IF( ABS( XJ-XJM ).GT.ORTOL ) $ GPIND = J IF( GPIND.NE.J ) THEN DO 100 I = GPIND, J - 1 ZTR = ZERO DO 80 JR = 1, BLKSIZ ZTR = ZTR + WORK( INDRV1+JR )* $ DBLE( Z( B1-1+JR, I ) ) 80 CONTINUE DO 90 JR = 1, BLKSIZ WORK( INDRV1+JR ) = WORK( INDRV1+JR ) - $ ZTR*DBLE( Z( B1-1+JR, I ) ) 90 CONTINUE 100 CONTINUE END IF * * Check the infinity norm of the iterate. * 110 CONTINUE JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) NRM = ABS( WORK( INDRV1+JMAX ) ) * * Continue for additional iterations after norm reaches * stopping criterion. * IF( NRM.LT.DTPCRT ) $ GO TO 70 NRMCHK = NRMCHK + 1 IF( NRMCHK.LT.EXTRA+1 ) $ GO TO 70 * GO TO 130 * * If stopping criterion was not satisfied, update info and * store eigenvector number in array ifail. * 120 CONTINUE INFO = INFO + 1 IFAIL( INFO ) = J * * Accept iterate as jth eigenvector. * 130 CONTINUE SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) IF( WORK( INDRV1+JMAX ).LT.ZERO ) $ SCL = -SCL CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) 140 CONTINUE DO 150 I = 1, N Z( I, J ) = CZERO 150 CONTINUE DO 160 I = 1, BLKSIZ Z( B1+I-1, J ) = DCMPLX( WORK( INDRV1+I ), ZERO ) 160 CONTINUE * * Save the shift to check eigenvalue spacing at next * iteration. * XJM = XJ * 170 CONTINUE 180 CONTINUE * RETURN * * End of ZSTEIN * END SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO INTEGER INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNMTR overwrites the general complex M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'C': Q**H * C C * Q**H * * where Q is a complex unitary matrix of order nq, with nq = m if * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of * nq-1 elementary reflectors, as returned by ZHETRD: * * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); * * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**H from the Left; * = 'R': apply Q or Q**H from the Right. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A contains elementary reflectors * from ZHETRD; * = 'L': Lower triangle of A contains elementary reflectors * from ZHETRD. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'C': Conjugate transpose, apply Q**H. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * A (input) COMPLEX*16 array, dimension * (LDA,M) if SIDE = 'L' * (LDA,N) if SIDE = 'R' * The vectors which define the elementary reflectors, as * returned by ZHETRD. * * LDA (input) INTEGER * The leading dimension of the array A. * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. * * TAU (input) COMPLEX*16 array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZHETRD. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >=M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, LQUERY, UPPER INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNMQL, ZUNMQR * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) $ THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN IF( UPPER ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMTR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( LEFT ) THEN MI = M - 1 NI = N ELSE MI = M NI = N - 1 END IF * IF( UPPER ) THEN * * Q was determined by a call to ZHETRD with UPLO = 'U' * CALL ZUNMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, $ LDC, WORK, LWORK, IINFO ) ELSE * * Q was determined by a call to ZHETRD with UPLO = 'L' * IF( LEFT ) THEN I1 = 2 I2 = 1 ELSE I1 = 1 I2 = 2 END IF CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMTR * END SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDW, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION E( * ) COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * ) * .. * * Purpose * ======= * * ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to * Hermitian tridiagonal form by a unitary similarity * transformation Q' * A * Q, and returns the matrices V and W which are * needed to apply the transformation to the unreduced part of A. * * If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a * matrix, of which the upper triangle is supplied; * if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a * matrix, of which the lower triangle is supplied. * * This is an auxiliary routine called by ZHETRD. * * Arguments * ========= * * UPLO (input) CHARACTER * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored: * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. * * NB (input) INTEGER * The number of rows and columns to be reduced. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * n-by-n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n-by-n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit: * if UPLO = 'U', the last NB columns have been reduced to * tridiagonal form, with the diagonal elements overwriting * the diagonal elements of A; the elements above the diagonal * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors; * if UPLO = 'L', the first NB columns have been reduced to * tridiagonal form, with the diagonal elements overwriting * the diagonal elements of A; the elements below the diagonal * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * E (output) DOUBLE PRECISION array, dimension (N-1) * If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal * elements of the last NB columns of the reduced matrix; * if UPLO = 'L', E(1:nb) contains the subdiagonal elements of * the first NB columns of the reduced matrix. * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors, stored in * TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. * See Further Details. * * W (output) COMPLEX*16 array, dimension (LDW,NB) * The n-by-nb matrix W required to update the unreduced part * of A. * * LDW (input) INTEGER * The leading dimension of the array W. LDW >= max(1,N). * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n) H(n-1) . . . H(n-nb+1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), * and tau in TAU(i-1). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(nb). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), * and tau in TAU(i). * * The elements of the vectors v together form the n-by-nb matrix V * which is needed, with W, to apply the transformation to the unreduced * part of the matrix, using a Hermitian rank-2k update of the form: * A := A - V*W' - W*V'. * * The contents of A on exit are illustrated by the following examples * with n = 5 and nb = 2: * * if UPLO = 'U': if UPLO = 'L': * * ( a a a v4 v5 ) ( d ) * ( a a v4 v5 ) ( 1 d ) * ( a 1 v5 ) ( v1 1 a ) * ( d 1 ) ( v1 v2 a a ) * ( d ) ( v1 v2 a a a ) * * where d denotes a diagonal element of the reduced matrix, a denotes * an element of the original matrix that is unchanged, and vi denotes * an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE, HALF PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ), $ HALF = ( 0.5D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, IW COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL * .. * .. External Functions .. LOGICAL LSAME COMPLEX*16 ZDOTC EXTERNAL LSAME, ZDOTC * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( LSAME( UPLO, 'U' ) ) THEN * * Reduce last NB columns of upper triangle * DO 10 I = N, N - NB + 1, -1 IW = I - N + NB IF( I.LT.N ) THEN * * Update A(1:i,i) * A( I, I ) = DBLE( A( I, I ) ) CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) CALL ZLACGV( N-I, W( I, IW+1 ), LDW ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) A( I, I ) = DBLE( A( I, I ) ) END IF IF( I.GT.1 ) THEN * * Generate elementary reflector H(i) to annihilate * A(1:i-2,i) * ALPHA = A( I-1, I ) CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) ) E( I-1 ) = ALPHA A( I-1, I ) = ONE * * Compute W(1:i-1,i) * CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, $ ZERO, W( 1, IW ), 1 ) IF( I.LT.N ) THEN CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, $ W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO, $ W( I+1, IW ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, $ W( 1, IW ), 1 ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE, $ A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO, $ W( I+1, IW ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I, -ONE, $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, $ W( 1, IW ), 1 ) END IF CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1, $ A( 1, I ), 1 ) CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) END IF * 10 CONTINUE ELSE * * Reduce first NB columns of lower triangle * DO 20 I = 1, NB * * Update A(i:n,i) * A( I, I ) = DBLE( A( I, I ) ) CALL ZLACGV( I-1, W( I, 1 ), LDW ) CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) CALL ZLACGV( I-1, W( I, 1 ), LDW ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) A( I, I ) = DBLE( A( I, I ) ) IF( I.LT.N ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:n,i) * ALPHA = A( I+1, I ) CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) E( I ) = ALPHA A( I+1, I ) = ONE * * Compute W(i+1:n,i) * CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, $ W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO, $ W( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, $ W( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1, $ A( I+1, I ), 1 ) CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) END IF * 20 CONTINUE END IF * RETURN * * End of ZLATRD * END SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAU( * ) * .. * * Purpose * ======= * * ZHETD2 reduces a complex Hermitian matrix A to real symmetric * tridiagonal form T by a unitary similarity transformation: * Q' * A * Q = T. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored: * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * n-by-n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n-by-n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit, if UPLO = 'U', the diagonal and first superdiagonal * of A are overwritten by the corresponding elements of the * tridiagonal matrix T, and the elements above the first * superdiagonal, with the array TAU, represent the unitary * matrix Q as a product of elementary reflectors; if UPLO * = 'L', the diagonal and first subdiagonal of A are over- * written by the corresponding elements of the tridiagonal * matrix T, and the elements below the first subdiagonal, with * the array TAU, represent the unitary matrix Q as a product * of elementary reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * D (output) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the tridiagonal matrix T: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (N-1) * The off-diagonal elements of the tridiagonal matrix T: * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. * * TAU (output) COMPLEX*16 array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n-1) . . . H(2) H(1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in * A(1:i-1,i+1), and tau in TAU(i). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(n-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), * and tau in TAU(i). * * The contents of A on exit are illustrated by the following examples * with n = 5: * * if UPLO = 'U': if UPLO = 'L': * * ( d e v2 v3 v4 ) ( d ) * ( d e v3 v4 ) ( e d ) * ( d e v4 ) ( v1 e d ) * ( d e ) ( v1 v2 e d ) * ( d ) ( v1 v2 v3 e d ) * * where d and e denote diagonal and off-diagonal elements of T, and vi * denotes an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO, HALF PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ), $ HALF = ( 0.5D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I COMPLEX*16 ALPHA, TAUI * .. * .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG * .. * .. External Functions .. LOGICAL LSAME COMPLEX*16 ZDOTC EXTERNAL LSAME, ZDOTC * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHETD2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( UPPER ) THEN * * Reduce the upper triangle of A * A( N, N ) = DBLE( A( N, N ) ) DO 10 I = N - 1, 1, -1 * * Generate elementary reflector H(i) = I - tau * v * v' * to annihilate A(1:i-1,i+1) * ALPHA = A( I, I+1 ) CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI ) E( I ) = ALPHA * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(1:i,1:i) * A( I, I+1 ) = ONE * * Compute x := tau * A * v storing x in TAU(1:i) * CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, $ TAU, 1 ) * * Compute w := x - 1/2 * tau * (x'*v) * v * ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 ) CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w' - w * v' * CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, $ LDA ) * ELSE A( I, I ) = DBLE( A( I, I ) ) END IF A( I, I+1 ) = E( I ) D( I+1 ) = A( I+1, I+1 ) TAU( I ) = TAUI 10 CONTINUE D( 1 ) = A( 1, 1 ) ELSE * * Reduce the lower triangle of A * A( 1, 1 ) = DBLE( A( 1, 1 ) ) DO 20 I = 1, N - 1 * * Generate elementary reflector H(i) = I - tau * v * v' * to annihilate A(i+2:n,i) * ALPHA = A( I+1, I ) CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI ) E( I ) = ALPHA * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(i+1:n,i+1:n) * A( I+1, I ) = ONE * * Compute x := tau * A * v storing y in TAU(i:n-1) * CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) * * Compute w := x - 1/2 * tau * (x'*v) * v * ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ), $ 1 ) CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w' - w * v' * CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, $ A( I+1, I+1 ), LDA ) * ELSE A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) ) END IF A( I+1, I ) = E( I ) D( I ) = A( I, I ) TAU( I ) = TAUI 20 CONTINUE D( N ) = A( N, N ) END IF * RETURN * * End of ZHETD2 * END SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns, * which is defined as the last N columns of a product of K elementary * reflectors of order M * * Q = H(k) . . . H(2) H(1) * * as returned by ZGEQLF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the (n-k+i)-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGEQLF in the last k columns of its array * argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, $ NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2L * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the first block. * The last kk columns are handled by the block method. * KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) * * Set A(m-kk+1:m,1:n-kk) to zero. * DO 20 J = 1, N - KK DO 10 I = M - KK + 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the first or only block. * CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = K - KK + 1, K, NB IB = MIN( NB, K-I+1 ) IF( N-K+I.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left * CALL ZLARFB( 'Left', 'No transpose', 'Backward', $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, $ WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows 1:m-k+i+ib-1 of current block * CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, $ TAU( I ), WORK, IINFO ) * * Set rows m-k+i+ib:m of current block to zero * DO 40 J = N - K + I, N - K + I + IB - 1 DO 30 L = M - K + I + IB, M A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of ZUNGQL * END SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, * which is defined as the first N columns of a product of K elementary * reflectors of order M * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the i-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by ZGEQRF in the first k columns of its array * argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNG2R * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL ZLARFB( 'Left', 'No transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows i:m of current block * CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of ZUNGQR * END SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, $ NAB, WORK, IWORK, INFO ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL * .. * .. Array Arguments .. INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), $ WORK( * ) * .. * * Purpose * ======= * * DLAEBZ contains the iteration loops which compute and use the * function N(w), which is the count of eigenvalues of a symmetric * tridiagonal matrix T less than or equal to its argument w. It * performs a choice of two types of loops: * * IJOB=1, followed by * IJOB=2: It takes as input a list of intervals and returns a list of * sufficiently small intervals whose union contains the same * eigenvalues as the union of the original intervals. * The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. * The output interval (AB(j,1),AB(j,2)] will contain * eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. * * IJOB=3: It performs a binary search in each input interval * (AB(j,1),AB(j,2)] for a point w(j) such that * N(w(j))=NVAL(j), and uses C(j) as the starting point of * the search. If such a w(j) is found, then on output * AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output * (AB(j,1),AB(j,2)] will be a small interval containing the * point where N(w) jumps through NVAL(j), unless that point * lies outside the initial interval. * * Note that the intervals are in all cases half-open intervals, * i.e., of the form (a,b] , which includes b but not a . * * To avoid underflow, the matrix should be scaled so that its largest * element is no greater than overflow**(1/2) * underflow**(1/4) * in absolute value. To assure the most accurate computation * of small eigenvalues, the matrix should be scaled to be * not much smaller than that, either. * * See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal * Matrix", Report CS41, Computer Science Dept., Stanford * University, July 21, 1966 * * Note: the arguments are, in general, *not* checked for unreasonable * values. * * Arguments * ========= * * IJOB (input) INTEGER * Specifies what is to be done: * = 1: Compute NAB for the initial intervals. * = 2: Perform bisection iteration to find eigenvalues of T. * = 3: Perform bisection iteration to invert N(w), i.e., * to find a point which has a specified number of * eigenvalues of T to its left. * Other values will cause DLAEBZ to return with INFO=-1. * * NITMAX (input) INTEGER * The maximum number of "levels" of bisection to be * performed, i.e., an interval of width W will not be made * smaller than 2^(-NITMAX) * W. If not all intervals * have converged after NITMAX iterations, then INFO is set * to the number of non-converged intervals. * * N (input) INTEGER * The dimension n of the tridiagonal matrix T. It must be at * least 1. * * MMAX (input) INTEGER * The maximum number of intervals. If more than MMAX intervals * are generated, then DLAEBZ will quit with INFO=MMAX+1. * * MINP (input) INTEGER * The initial number of intervals. It may not be greater than * MMAX. * * NBMIN (input) INTEGER * The smallest number of intervals that should be processed * using a vector loop. If zero, then only the scalar loop * will be used. * * ABSTOL (input) DOUBLE PRECISION * The minimum (absolute) width of an interval. When an * interval is narrower than ABSTOL, or than RELTOL times the * larger (in magnitude) endpoint, then it is considered to be * sufficiently small, i.e., converged. This must be at least * zero. * * RELTOL (input) DOUBLE PRECISION * The minimum relative width of an interval. When an interval * is narrower than ABSTOL, or than RELTOL times the larger (in * magnitude) endpoint, then it is considered to be * sufficiently small, i.e., converged. Note: this should * always be at least radix*machine epsilon. * * PIVMIN (input) DOUBLE PRECISION * The minimum absolute value of a "pivot" in the Sturm * sequence loop. This *must* be at least max |e(j)**2| * * safe_min and at least safe_min, where safe_min is at least * the smallest number that can divide one without overflow. * * D (input) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the tridiagonal matrix T. * * E (input) DOUBLE PRECISION array, dimension (N) * The offdiagonal elements of the tridiagonal matrix T in * positions 1 through N-1. E(N) is arbitrary. * * E2 (input) DOUBLE PRECISION array, dimension (N) * The squares of the offdiagonal elements of the tridiagonal * matrix T. E2(N) is ignored. * * NVAL (input/output) INTEGER array, dimension (MINP) * If IJOB=1 or 2, not referenced. * If IJOB=3, the desired values of N(w). The elements of NVAL * will be reordered to correspond with the intervals in AB. * Thus, NVAL(j) on output will not, in general be the same as * NVAL(j) on input, but it will correspond with the interval * (AB(j,1),AB(j,2)] on output. * * AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2) * The endpoints of the intervals. AB(j,1) is a(j), the left * endpoint of the j-th interval, and AB(j,2) is b(j), the * right endpoint of the j-th interval. The input intervals * will, in general, be modified, split, and reordered by the * calculation. * * C (input/output) DOUBLE PRECISION array, dimension (MMAX) * If IJOB=1, ignored. * If IJOB=2, workspace. * If IJOB=3, then on input C(j) should be initialized to the * first search point in the binary search. * * MOUT (output) INTEGER * If IJOB=1, the number of eigenvalues in the intervals. * If IJOB=2 or 3, the number of intervals output. * If IJOB=3, MOUT will equal MINP. * * NAB (input/output) INTEGER array, dimension (MMAX,2) * If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). * If IJOB=2, then on input, NAB(i,j) should be set. It must * satisfy the condition: * N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), * which means that in interval i only eigenvalues * NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, * NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with * IJOB=1. * On output, NAB(i,j) will contain * max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of * the input interval that the output interval * (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the * the input values of NAB(k,1) and NAB(k,2). * If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), * unless N(w) > NVAL(i) for all search points w , in which * case NAB(i,1) will not be modified, i.e., the output * value will be the same as the input value (modulo * reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) * for all search points w , in which case NAB(i,2) will * not be modified. Normally, NAB should be set to some * distinctive value(s) before DLAEBZ is called. * * WORK (workspace) DOUBLE PRECISION array, dimension (MMAX) * Workspace. * * IWORK (workspace) INTEGER array, dimension (MMAX) * Workspace. * * INFO (output) INTEGER * = 0: All intervals converged. * = 1--MMAX: The last INFO intervals did not converge. * = MMAX+1: More than MMAX intervals were generated. * * Further Details * =============== * * This routine is intended to be called only by other LAPACK * routines, thus the interface is less user-friendly. It is intended * for two purposes: * * (a) finding eigenvalues. In this case, DLAEBZ should have one or * more initial intervals set up in AB, and DLAEBZ should be called * with IJOB=1. This sets up NAB, and also counts the eigenvalues. * Intervals with no eigenvalues would usually be thrown out at * this point. Also, if not all the eigenvalues in an interval i * are desired, NAB(i,1) can be increased or NAB(i,2) decreased. * For example, set NAB(i,1)=NAB(i,2)-1 to get the largest * eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX * no smaller than the value of MOUT returned by the call with * IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 * through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the * tolerance specified by ABSTOL and RELTOL. * * (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). * In this case, start with a Gershgorin interval (a,b). Set up * AB to contain 2 search intervals, both initially (a,b). One * NVAL element should contain f-1 and the other should contain l * , while C should contain a and b, resp. NAB(i,1) should be -1 * and NAB(i,2) should be N+1, to flag an error if the desired * interval does not lie in (a,b). DLAEBZ is then called with * IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- * j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while * if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r * >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and * N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and * w(l-r)=...=w(l+k) are handled similarly. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, TWO, HALF PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, $ HALF = 1.0D0 / TWO ) * .. * .. Local Scalars .. INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, $ KLNEW DOUBLE PRECISION TMP1, TMP2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * * Check for Errors * INFO = 0 IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN INFO = -1 RETURN END IF * * Initialize NAB * IF( IJOB.EQ.1 ) THEN * * Compute the number of eigenvalues in the initial intervals. * MOUT = 0 *DIR$ NOVECTOR DO 30 JI = 1, MINP DO 20 JP = 1, 2 TMP1 = D( 1 ) - AB( JI, JP ) IF( ABS( TMP1 ).LT.PIVMIN ) $ TMP1 = -PIVMIN NAB( JI, JP ) = 0 IF( TMP1.LE.ZERO ) $ NAB( JI, JP ) = 1 * DO 10 J = 2, N TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP ) IF( ABS( TMP1 ).LT.PIVMIN ) $ TMP1 = -PIVMIN IF( TMP1.LE.ZERO ) $ NAB( JI, JP ) = NAB( JI, JP ) + 1 10 CONTINUE 20 CONTINUE MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 ) 30 CONTINUE RETURN END IF * * Initialize for loop * * KF and KL have the following meaning: * Intervals 1,...,KF-1 have converged. * Intervals KF,...,KL still need to be refined. * KF = 1 KL = MINP * * If IJOB=2, initialize C. * If IJOB=3, use the user-supplied starting point. * IF( IJOB.EQ.2 ) THEN DO 40 JI = 1, MINP C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) 40 CONTINUE END IF * * Iteration loop * DO 130 JIT = 1, NITMAX * * Loop over intervals * IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN * * Begin of Parallel Version of the loop * DO 60 JI = KF, KL * * Compute N(c), the number of eigenvalues less than c * WORK( JI ) = D( 1 ) - C( JI ) IWORK( JI ) = 0 IF( WORK( JI ).LE.PIVMIN ) THEN IWORK( JI ) = 1 WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) END IF * DO 50 J = 2, N WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI ) IF( WORK( JI ).LE.PIVMIN ) THEN IWORK( JI ) = IWORK( JI ) + 1 WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) END IF 50 CONTINUE 60 CONTINUE * IF( IJOB.LE.2 ) THEN * * IJOB=2: Choose all intervals containing eigenvalues. * KLNEW = KL DO 70 JI = KF, KL * * Insure that N(w) is monotone * IWORK( JI ) = MIN( NAB( JI, 2 ), $ MAX( NAB( JI, 1 ), IWORK( JI ) ) ) * * Update the Queue -- add intervals if both halves * contain eigenvalues. * IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN * * No eigenvalue in the upper interval: * just use the lower interval. * AB( JI, 2 ) = C( JI ) * ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN * * No eigenvalue in the lower interval: * just use the upper interval. * AB( JI, 1 ) = C( JI ) ELSE KLNEW = KLNEW + 1 IF( KLNEW.LE.MMAX ) THEN * * Eigenvalue in both intervals -- add upper to * queue. * AB( KLNEW, 2 ) = AB( JI, 2 ) NAB( KLNEW, 2 ) = NAB( JI, 2 ) AB( KLNEW, 1 ) = C( JI ) NAB( KLNEW, 1 ) = IWORK( JI ) AB( JI, 2 ) = C( JI ) NAB( JI, 2 ) = IWORK( JI ) ELSE INFO = MMAX + 1 END IF END IF 70 CONTINUE IF( INFO.NE.0 ) $ RETURN KL = KLNEW ELSE * * IJOB=3: Binary search. Keep only the interval containing * w s.t. N(w) = NVAL * DO 80 JI = KF, KL IF( IWORK( JI ).LE.NVAL( JI ) ) THEN AB( JI, 1 ) = C( JI ) NAB( JI, 1 ) = IWORK( JI ) END IF IF( IWORK( JI ).GE.NVAL( JI ) ) THEN AB( JI, 2 ) = C( JI ) NAB( JI, 2 ) = IWORK( JI ) END IF 80 CONTINUE END IF * ELSE * * End of Parallel Version of the loop * * Begin of Serial Version of the loop * KLNEW = KL DO 100 JI = KF, KL * * Compute N(w), the number of eigenvalues less than w * TMP1 = C( JI ) TMP2 = D( 1 ) - TMP1 ITMP1 = 0 IF( TMP2.LE.PIVMIN ) THEN ITMP1 = 1 TMP2 = MIN( TMP2, -PIVMIN ) END IF * * A series of compiler directives to defeat vectorization * for the next loop * *$PL$ CMCHAR=' ' CDIR$ NEXTSCALAR C$DIR SCALAR CDIR$ NEXT SCALAR CVD$L NOVECTOR CDEC$ NOVECTOR CVD$ NOVECTOR *VDIR NOVECTOR *VOCL LOOP,SCALAR CIBM PREFER SCALAR *$PL$ CMCHAR='*' * DO 90 J = 2, N TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1 IF( TMP2.LE.PIVMIN ) THEN ITMP1 = ITMP1 + 1 TMP2 = MIN( TMP2, -PIVMIN ) END IF 90 CONTINUE * IF( IJOB.LE.2 ) THEN * * IJOB=2: Choose all intervals containing eigenvalues. * * Insure that N(w) is monotone * ITMP1 = MIN( NAB( JI, 2 ), $ MAX( NAB( JI, 1 ), ITMP1 ) ) * * Update the Queue -- add intervals if both halves * contain eigenvalues. * IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN * * No eigenvalue in the upper interval: * just use the lower interval. * AB( JI, 2 ) = TMP1 * ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN * * No eigenvalue in the lower interval: * just use the upper interval. * AB( JI, 1 ) = TMP1 ELSE IF( KLNEW.LT.MMAX ) THEN * * Eigenvalue in both intervals -- add upper to queue. * KLNEW = KLNEW + 1 AB( KLNEW, 2 ) = AB( JI, 2 ) NAB( KLNEW, 2 ) = NAB( JI, 2 ) AB( KLNEW, 1 ) = TMP1 NAB( KLNEW, 1 ) = ITMP1 AB( JI, 2 ) = TMP1 NAB( JI, 2 ) = ITMP1 ELSE INFO = MMAX + 1 RETURN END IF ELSE * * IJOB=3: Binary search. Keep only the interval * containing w s.t. N(w) = NVAL * IF( ITMP1.LE.NVAL( JI ) ) THEN AB( JI, 1 ) = TMP1 NAB( JI, 1 ) = ITMP1 END IF IF( ITMP1.GE.NVAL( JI ) ) THEN AB( JI, 2 ) = TMP1 NAB( JI, 2 ) = ITMP1 END IF END IF 100 CONTINUE KL = KLNEW * * End of Serial Version of the loop * END IF * * Check for convergence * KFNEW = KF DO 110 JI = KF, KL TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) ) TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) ) IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN * * Converged -- Swap with position KFNEW, * then increment KFNEW * IF( JI.GT.KFNEW ) THEN TMP1 = AB( JI, 1 ) TMP2 = AB( JI, 2 ) ITMP1 = NAB( JI, 1 ) ITMP2 = NAB( JI, 2 ) AB( JI, 1 ) = AB( KFNEW, 1 ) AB( JI, 2 ) = AB( KFNEW, 2 ) NAB( JI, 1 ) = NAB( KFNEW, 1 ) NAB( JI, 2 ) = NAB( KFNEW, 2 ) AB( KFNEW, 1 ) = TMP1 AB( KFNEW, 2 ) = TMP2 NAB( KFNEW, 1 ) = ITMP1 NAB( KFNEW, 2 ) = ITMP2 IF( IJOB.EQ.3 ) THEN ITMP1 = NVAL( JI ) NVAL( JI ) = NVAL( KFNEW ) NVAL( KFNEW ) = ITMP1 END IF END IF KFNEW = KFNEW + 1 END IF 110 CONTINUE KF = KFNEW * * Choose Midpoints * DO 120 JI = KF, KL C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) 120 CONTINUE * * If no more intervals to refine, quit. * IF( KF.GT.KL ) $ GO TO 140 130 CONTINUE * * Converged * 140 CONTINUE INFO = MAX( KL+1-KF, 0 ) MOUT = KL * RETURN * * End of DLAEBZ * END SUBROUTINE DLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION X( * ) * .. * * Purpose * ======= * * DLARNV returns a vector of n random real numbers from a uniform or * normal distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: uniform (0,1) * = 2: uniform (-1,1) * = 3: normal (0,1) * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * N (input) INTEGER * The number of random numbers to be generated. * * X (output) DOUBLE PRECISION array, dimension (N) * The generated random numbers. * * Further Details * =============== * * This routine calls the auxiliary routine DLARUV to generate random * real numbers from a uniform (0,1) distribution, in batches of up to * 128 using vectorisable code. The Box-Muller method is used to * transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) INTEGER LV PARAMETER ( LV = 128 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IL2, IV * .. * .. Local Arrays .. DOUBLE PRECISION U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL DLARUV * .. * .. Executable Statements .. * DO 40 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) IF( IDIST.EQ.3 ) THEN IL2 = 2*IL ELSE IL2 = IL END IF * * Call DLARUV to generate IL2 numbers from a uniform (0,1) * distribution (IL2 <= LV) * CALL DLARUV( ISEED, IL2, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = U( I ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = TWO*U( I ) - ONE 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ COS( TWOPI*U( 2*I ) ) 30 CONTINUE END IF 40 CONTINUE RETURN * * End of DLARNV * END SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, N DOUBLE PRECISION LAMBDA, TOL * .. * .. Array Arguments .. INTEGER IN( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) * .. * * Purpose * ======= * * DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n * tridiagonal matrix and lambda is a scalar, as * * T - lambda*I = PLU, * * where P is a permutation matrix, L is a unit lower tridiagonal matrix * with at most one non-zero sub-diagonal elements per column and U is * an upper triangular matrix with at most two non-zero super-diagonal * elements per column. * * The factorization is obtained by Gaussian elimination with partial * pivoting and implicit row scaling. * * The parameter LAMBDA is included in the routine so that DLAGTF may * be used, in conjunction with DLAGTS, to obtain eigenvectors of T by * inverse iteration. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix T. * * A (input/output) DOUBLE PRECISION array, dimension (N) * On entry, A must contain the diagonal elements of T. * * On exit, A is overwritten by the n diagonal elements of the * upper triangular matrix U of the factorization of T. * * LAMBDA (input) DOUBLE PRECISION * On entry, the scalar lambda. * * B (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, B must contain the (n-1) super-diagonal elements of * T. * * On exit, B is overwritten by the (n-1) super-diagonal * elements of the matrix U of the factorization of T. * * C (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, C must contain the (n-1) sub-diagonal elements of * T. * * On exit, C is overwritten by the (n-1) sub-diagonal elements * of the matrix L of the factorization of T. * * TOL (input) DOUBLE PRECISION * On entry, a relative tolerance used to indicate whether or * not the matrix (T - lambda*I) is nearly singular. TOL should * normally be chose as approximately the largest relative error * in the elements of T. For example, if the elements of T are * correct to about 4 significant figures, then TOL should be * set to about 5*10**(-4). If TOL is supplied as less than eps, * where eps is the relative machine precision, then the value * eps is used in place of TOL. * * D (output) DOUBLE PRECISION array, dimension (N-2) * On exit, D is overwritten by the (n-2) second super-diagonal * elements of the matrix U of the factorization of T. * * IN (output) INTEGER array, dimension (N) * On exit, IN contains details of the permutation matrix P. If * an interchange occurred at the kth step of the elimination, * then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) * returns the smallest positive integer j such that * * abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, * * where norm( A(j) ) denotes the sum of the absolute values of * the jth row of the matrix A. If no such j exists then IN(n) * is returned as zero. If IN(n) is returned as positive, then a * diagonal element of U is small, indicating that * (T - lambda*I) is singular or nearly singular, * * INFO (output) INTEGER * = 0 : successful exit * .lt. 0: if INFO = -k, the kth argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER K DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DLAGTF', -INFO ) RETURN END IF * IF( N.EQ.0 ) $ RETURN * A( 1 ) = A( 1 ) - LAMBDA IN( N ) = 0 IF( N.EQ.1 ) THEN IF( A( 1 ).EQ.ZERO ) $ IN( 1 ) = 1 RETURN END IF * EPS = DLAMCH( 'Epsilon' ) * TL = MAX( TOL, EPS ) SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) ) DO 10 K = 1, N - 1 A( K+1 ) = A( K+1 ) - LAMBDA SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) ) IF( K.LT.( N-1 ) ) $ SCALE2 = SCALE2 + ABS( B( K+1 ) ) IF( A( K ).EQ.ZERO ) THEN PIV1 = ZERO ELSE PIV1 = ABS( A( K ) ) / SCALE1 END IF IF( C( K ).EQ.ZERO ) THEN IN( K ) = 0 PIV2 = ZERO SCALE1 = SCALE2 IF( K.LT.( N-1 ) ) $ D( K ) = ZERO ELSE PIV2 = ABS( C( K ) ) / SCALE2 IF( PIV2.LE.PIV1 ) THEN IN( K ) = 0 SCALE1 = SCALE2 C( K ) = C( K ) / A( K ) A( K+1 ) = A( K+1 ) - C( K )*B( K ) IF( K.LT.( N-1 ) ) $ D( K ) = ZERO ELSE IN( K ) = 1 MULT = A( K ) / C( K ) A( K ) = C( K ) TEMP = A( K+1 ) A( K+1 ) = B( K ) - MULT*TEMP IF( K.LT.( N-1 ) ) THEN D( K ) = B( K+1 ) B( K+1 ) = -MULT*D( K ) END IF B( K ) = TEMP C( K ) = MULT END IF END IF IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) ) $ IN( N ) = K 10 CONTINUE IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) ) $ IN( N ) = N * RETURN * * End of DLAGTF * END SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INFO, JOB, N DOUBLE PRECISION TOL * .. * .. Array Arguments .. INTEGER IN( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) * .. * * Purpose * ======= * * DLAGTS may be used to solve one of the systems of equations * * (T - lambda*I)*x = y or (T - lambda*I)'*x = y, * * where T is an n by n tridiagonal matrix, for x, following the * factorization of (T - lambda*I) as * * (T - lambda*I) = P*L*U , * * by routine DLAGTF. The choice of equation to be solved is * controlled by the argument JOB, and in each case there is an option * to perturb zero or very small diagonal elements of U, this option * being intended for use in applications such as inverse iteration. * * Arguments * ========= * * JOB (input) INTEGER * Specifies the job to be performed by DLAGTS as follows: * = 1: The equations (T - lambda*I)x = y are to be solved, * but diagonal elements of U are not to be perturbed. * = -1: The equations (T - lambda*I)x = y are to be solved * and, if overflow would otherwise occur, the diagonal * elements of U are to be perturbed. See argument TOL * below. * = 2: The equations (T - lambda*I)'x = y are to be solved, * but diagonal elements of U are not to be perturbed. * = -2: The equations (T - lambda*I)'x = y are to be solved * and, if overflow would otherwise occur, the diagonal * elements of U are to be perturbed. See argument TOL * below. * * N (input) INTEGER * The order of the matrix T. * * A (input) DOUBLE PRECISION array, dimension (N) * On entry, A must contain the diagonal elements of U as * returned from DLAGTF. * * B (input) DOUBLE PRECISION array, dimension (N-1) * On entry, B must contain the first super-diagonal elements of * U as returned from DLAGTF. * * C (input) DOUBLE PRECISION array, dimension (N-1) * On entry, C must contain the sub-diagonal elements of L as * returned from DLAGTF. * * D (input) DOUBLE PRECISION array, dimension (N-2) * On entry, D must contain the second super-diagonal elements * of U as returned from DLAGTF. * * IN (input) INTEGER array, dimension (N) * On entry, IN must contain details of the matrix P as returned * from DLAGTF. * * Y (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the right hand side vector y. * On exit, Y is overwritten by the solution vector x. * * TOL (input/output) DOUBLE PRECISION * On entry, with JOB .lt. 0, TOL should be the minimum * perturbation to be made to very small diagonal elements of U. * TOL should normally be chosen as about eps*norm(U), where eps * is the relative machine precision, but if TOL is supplied as * non-positive, then it is reset to eps*max( abs( u(i,j) ) ). * If JOB .gt. 0 then TOL is not referenced. * * On exit, TOL is changed as described above, only if TOL is * non-positive on entry. Otherwise TOL is unchanged. * * INFO (output) INTEGER * = 0 : successful exit * .lt. 0: if INFO = -i, the i-th argument had an illegal value * .gt. 0: overflow would occur when computing the INFO(th) * element of the solution vector x. This can only occur * when JOB is supplied as positive and either means * that a diagonal element of U is very small, or that * the elements of the right-hand side vector y are very * large. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER K DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * INFO = 0 IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLAGTS', -INFO ) RETURN END IF * IF( N.EQ.0 ) $ RETURN * EPS = DLAMCH( 'Epsilon' ) SFMIN = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SFMIN * IF( JOB.LT.0 ) THEN IF( TOL.LE.ZERO ) THEN TOL = ABS( A( 1 ) ) IF( N.GT.1 ) $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) ) DO 10 K = 3, N TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), $ ABS( D( K-2 ) ) ) 10 CONTINUE TOL = TOL*EPS IF( TOL.EQ.ZERO ) $ TOL = EPS END IF END IF * IF( ABS( JOB ).EQ.1 ) THEN DO 20 K = 2, N IF( IN( K-1 ).EQ.0 ) THEN Y( K ) = Y( K ) - C( K-1 )*Y( K-1 ) ELSE TEMP = Y( K-1 ) Y( K-1 ) = Y( K ) Y( K ) = TEMP - C( K-1 )*Y( K ) END IF 20 CONTINUE IF( JOB.EQ.1 ) THEN DO 30 K = N, 1, -1 IF( K.LE.N-2 ) THEN TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) ELSE IF( K.EQ.N-1 ) THEN TEMP = Y( K ) - B( K )*Y( K+1 ) ELSE TEMP = Y( K ) END IF AK = A( K ) ABSAK = ABS( AK ) IF( ABSAK.LT.ONE ) THEN IF( ABSAK.LT.SFMIN ) THEN IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) $ THEN INFO = K RETURN ELSE TEMP = TEMP*BIGNUM AK = AK*BIGNUM END IF ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN INFO = K RETURN END IF END IF Y( K ) = TEMP / AK 30 CONTINUE ELSE DO 50 K = N, 1, -1 IF( K.LE.N-2 ) THEN TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) ELSE IF( K.EQ.N-1 ) THEN TEMP = Y( K ) - B( K )*Y( K+1 ) ELSE TEMP = Y( K ) END IF AK = A( K ) PERT = SIGN( TOL, AK ) 40 CONTINUE ABSAK = ABS( AK ) IF( ABSAK.LT.ONE ) THEN IF( ABSAK.LT.SFMIN ) THEN IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) $ THEN AK = AK + PERT PERT = 2*PERT GO TO 40 ELSE TEMP = TEMP*BIGNUM AK = AK*BIGNUM END IF ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN AK = AK + PERT PERT = 2*PERT GO TO 40 END IF END IF Y( K ) = TEMP / AK 50 CONTINUE END IF ELSE * * Come to here if JOB = 2 or -2 * IF( JOB.EQ.2 ) THEN DO 60 K = 1, N IF( K.GE.3 ) THEN TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) ELSE IF( K.EQ.2 ) THEN TEMP = Y( K ) - B( K-1 )*Y( K-1 ) ELSE TEMP = Y( K ) END IF AK = A( K ) ABSAK = ABS( AK ) IF( ABSAK.LT.ONE ) THEN IF( ABSAK.LT.SFMIN ) THEN IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) $ THEN INFO = K RETURN ELSE TEMP = TEMP*BIGNUM AK = AK*BIGNUM END IF ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN INFO = K RETURN END IF END IF Y( K ) = TEMP / AK 60 CONTINUE ELSE DO 80 K = 1, N IF( K.GE.3 ) THEN TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) ELSE IF( K.EQ.2 ) THEN TEMP = Y( K ) - B( K-1 )*Y( K-1 ) ELSE TEMP = Y( K ) END IF AK = A( K ) PERT = SIGN( TOL, AK ) 70 CONTINUE ABSAK = ABS( AK ) IF( ABSAK.LT.ONE ) THEN IF( ABSAK.LT.SFMIN ) THEN IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) $ THEN AK = AK + PERT PERT = 2*PERT GO TO 70 ELSE TEMP = TEMP*BIGNUM AK = AK*BIGNUM END IF ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN AK = AK + PERT PERT = 2*PERT GO TO 70 END IF END IF Y( K ) = TEMP / AK 80 CONTINUE END IF * DO 90 K = N, 2, -1 IF( IN( K-1 ).EQ.0 ) THEN Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K ) ELSE TEMP = Y( K-1 ) Y( K-1 ) = Y( K ) Y( K ) = TEMP - C( K-1 )*Y( K ) END IF 90 CONTINUE END IF * * End of DLAGTS * END SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNMQL overwrites the general complex M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'C': Q**H * C C * Q**H * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(k) . . . H(2) H(1) * * as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**H from the Left; * = 'R': apply Q or Q**H from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'C': Transpose, apply Q**H. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGEQLF in the last k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, $ MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2L * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. NB may be at most NBMAX, where NBMAX * is used to define the local array T. * NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQL', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMQL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IWS = NW*NB IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQL', SIDE // TRANS, M, N, K, $ -1 ) ) END IF ELSE IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL ZLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, $ A( 1, I ), LDA, TAU( I ), T, LDT ) IF( LEFT ) THEN * * H or H' is applied to C(1:m-k+i+ib-1,1:n) * MI = M - K + I + IB - 1 ELSE * * H or H' is applied to C(1:m,1:n-k+i+ib-1) * NI = N - K + I + IB - 1 END IF * * Apply H or H' * CALL ZLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, $ LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMQL * END SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNMQR overwrites the general complex M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'C': Q**H * C C * Q**H * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**H from the Left; * = 'R': apply Q or Q**H from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'C': Conjugate transpose, apply Q**H. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNM2R * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. NB may be at most NBMAX, where NBMAX * is used to define the local array T. * NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IWS = NW*NB IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF ELSE IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), T, LDT ) IF( LEFT ) THEN * * H or H' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H' * CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, $ WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMQR * END SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * Purpose * ======= * * ZLARFT forms the triangular factor T of a complex block reflector H * of order n, which is defined as a product of k elementary reflectors. * * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; * * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. * * If STOREV = 'C', the vector which defines the elementary reflector * H(i) is stored in the i-th column of the array V, and * * H = I - V * T * V' * * If STOREV = 'R', the vector which defines the elementary reflector * H(i) is stored in the i-th row of the array V, and * * H = I - V' * T * V * * Arguments * ========= * * DIRECT (input) CHARACTER*1 * Specifies the order in which the elementary reflectors are * multiplied to form the block reflector: * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Specifies how the vectors which define the elementary * reflectors are stored (see also Further Details): * = 'C': columnwise * = 'R': rowwise * * N (input) INTEGER * The order of the block reflector H. N >= 0. * * K (input) INTEGER * The order of the triangular factor T (= the number of * elementary reflectors). K >= 1. * * V (input/output) COMPLEX*16 array, dimension * (LDV,K) if STOREV = 'C' * (LDV,N) if STOREV = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i). * * T (output) COMPLEX*16 array, dimension (LDT,K) * The k by k triangular factor T of the block reflector. * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is * lower triangular. The rest of the array is not used. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * Further Details * =============== * * The shape of the matrix V and the storage of the vectors which define * the H(i) is best illustrated by the following example with n = 5 and * k = 3. The elements equal to 1 are not stored; the corresponding * array elements are modified but restored on exit. The rest of the * array is not used. * * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': * * V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) * ( v1 1 ) ( 1 v2 v2 v2 ) * ( v1 v2 1 ) ( 1 v3 v3 ) * ( v1 v2 v3 ) * ( v1 v2 v3 ) * * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': * * V = ( v1 v2 v3 ) V = ( v1 v1 1 ) * ( v1 v2 v3 ) ( v2 v2 v2 1 ) * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) * ( 1 v3 ) * ( 1 ) * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J COMPLEX*16 VII * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZLACGV, ZTRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 I = 1, K IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 10 J = 1, I T( J, I ) = ZERO 10 CONTINUE ELSE * * general case * VII = V( I, I ) V( I, I ) = ONE IF( LSAME( STOREV, 'C' ) ) THEN * * T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) * CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, $ -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1, $ ZERO, T( 1, I ), 1 ) ELSE * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' * IF( I.LT.N ) $ CALL ZLACGV( N-I, V( I, I+1 ), LDV ) CALL ZGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, $ T( 1, I ), 1 ) IF( I.LT.N ) $ CALL ZLACGV( N-I, V( I, I+1 ), LDV ) END IF V( I, I ) = VII * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) END IF 20 CONTINUE ELSE DO 40 I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 30 J = I, K T( J, I ) = ZERO 30 CONTINUE ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN VII = V( N-K+I, I ) V( N-K+I, I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) * CALL ZGEMV( 'Conjugate transpose', N-K+I, K-I, $ -TAU( I ), V( 1, I+1 ), LDV, V( 1, I ), $ 1, ZERO, T( I+1, I ), 1 ) V( N-K+I, I ) = VII ELSE VII = V( I, N-K+I ) V( I, N-K+I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' * CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) CALL ZGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, $ T( I+1, I ), 1 ) CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV ) V( I, N-K+I ) = VII END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) END IF T( I, I ) = TAU( I ) END IF 40 CONTINUE END IF RETURN * * End of ZLARFT * END SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * Purpose * ======= * * ZLARFB applies a complex block reflector H or its transpose H' to a * complex M-by-N matrix C, from either the left or the right. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply H or H' from the Left * = 'R': apply H or H' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply H (No transpose) * = 'C': apply H' (Conjugate transpose) * * DIRECT (input) CHARACTER*1 * Indicates how H is formed from a product of elementary * reflectors * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Indicates how the vectors which define the elementary * reflectors are stored: * = 'C': Columnwise * = 'R': Rowwise * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * K (input) INTEGER * The order of the matrix T (= the number of elementary * reflectors whose product defines the block reflector). * * V (input) COMPLEX*16 array, dimension * (LDV,K) if STOREV = 'C' * (LDV,M) if STOREV = 'R' and SIDE = 'L' * (LDV,N) if STOREV = 'R' and SIDE = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); * if STOREV = 'R', LDV >= K. * * T (input) COMPLEX*16 array, dimension (LDT,K) * The triangular K-by-K matrix T in the representation of the * block reflector. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by H*C or H'*C or C*H or C*H'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) * * LDWORK (input) INTEGER * The leading dimension of the array WORK. * If SIDE = 'L', LDWORK >= max(1,N); * if SIDE = 'R', LDWORK >= max(1,M). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZGEMM, ZLACGV, ZTRMM * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C1' * DO 10 J = 1, K 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', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2 * 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' or W * T * CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK, $ LDWORK, ONE, C( K+1, 1 ), LDC ) END IF * * W := W * V1' * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * 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', 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' * CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C2 := C2 - W * V2' * 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' * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 60 J = 1, K DO 50 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C2' * DO 70 J = 1, K 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', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1 * CALL ZGEMM( 'Conjugate transpose', 'No transpose', N, $ K, M-K, ONE, C, LDC, V, LDV, ONE, WORK, $ LDWORK ) END IF * * W := W * T' or W * T * CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-K, N, K, -ONE, V, LDV, WORK, LDWORK, $ ONE, C, LDC ) END IF * * W := W * V2' * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK, $ LDWORK ) * * C2 := C2 - W' * DO 90 J = 1, K DO 80 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 80 CONTINUE 90 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * 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 ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 100 CONTINUE * * W := W * V2 * 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', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C1 := C1 - W * V1' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M, $ N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE, $ C, LDC ) END IF * * W := W * V2' * CALL ZTRMM( 'Right', 'Upper', 'Conjugate 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, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C1' * DO 130 J = 1, K CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) CALL ZLACGV( N, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1' * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', N, K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2' * CALL ZGEMM( 'Conjugate transpose', $ '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' or W * T * CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2' * W' * CALL ZGEMM( 'Conjugate transpose', $ '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', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1' * CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', $ 'Unit', M, K, ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2' * 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' * CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * 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', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C2' * DO 190 J = 1, K 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' * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK, $ LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1' * CALL ZGEMM( 'Conjugate transpose', $ 'Conjugate transpose', N, K, M-K, ONE, C, $ LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1' * W' * CALL ZGEMM( 'Conjugate transpose', $ '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', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W' * DO 210 J = 1, K DO 200 I = 1, N C( M-K+J, I ) = C( M-K+J, I ) - $ DCONJG( WORK( I, J ) ) 200 CONTINUE 210 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2' * CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose', $ 'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK, $ LDWORK ) IF( N.GT.K ) THEN * * W := W + C1 * V1' * 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' * CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * 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', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of ZLARFB * END SUBROUTINE DLARUV( ISEED, N, X ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION X( N ) * .. * * Purpose * ======= * * DLARUV returns a vector of n random real numbers from a uniform (0,1) * distribution (n <= 128). * * This is an auxiliary routine called by DLARNV and ZLARNV. * * Arguments * ========= * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * N (input) INTEGER * The number of random numbers to be generated. N <= 128. * * X (output) DOUBLE PRECISION array, dimension (N) * The generated random numbers. * * Further Details * =============== * * This routine uses a multiplicative congruential method with modulus * 2**48 and multiplier 33952834046453 (see G.S.Fishman, * 'Multiplicative congruential random number generators with modulus * 2**b: an exhaustive analysis for b = 32 and a partial analysis for * b = 48', Math. Comp. 189, pp 331-344, 1990). * * 48-bit integers are stored in 4 integer array elements with 12 bits * per element. Hence the routine is portable across machines with * integers of 32 bits or more. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) INTEGER LV, IPW2 DOUBLE PRECISION R PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J * .. * .. Local Arrays .. INTEGER MM( LV, 4 ) * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN, MOD * .. * .. Data statements .. DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, $ 2549 / DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, $ 1145 / DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, $ 2253 / DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, $ 305 / DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, $ 3301 / DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, $ 1065 / DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, $ 3133 / DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, $ 2913 / DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, $ 3285 / DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, $ 1241 / DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, $ 1197 / DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, $ 3729 / DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, $ 2501 / DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, $ 1673 / DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, $ 541 / DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, $ 2753 / DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, $ 949 / DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, $ 2361 / DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, $ 1165 / DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, $ 4081 / DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, $ 2725 / DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, $ 3305 / DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, $ 3069 / DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, $ 3617 / DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, $ 3733 / DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, $ 409 / DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, $ 2157 / DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, $ 1361 / DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, $ 3973 / DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, $ 1865 / DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, $ 2525 / DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, $ 1409 / DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, $ 3445 / DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, $ 3577 / DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, $ 77 / DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, $ 3761 / DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, $ 2149 / DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, $ 1449 / DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, $ 3005 / DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, $ 225 / DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, $ 85 / DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, $ 3673 / DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, $ 3117 / DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, $ 3089 / DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, $ 1349 / DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, $ 2057 / DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, $ 413 / DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, $ 65 / DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, $ 1845 / DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, $ 697 / DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, $ 3085 / DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, $ 3441 / DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, $ 1573 / DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, $ 3689 / DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, $ 2941 / DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, $ 929 / DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, $ 533 / DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, $ 2841 / DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, $ 4077 / DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, $ 721 / DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, $ 2821 / DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, $ 2249 / DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, $ 2397 / DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, $ 2817 / DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, $ 245 / DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, $ 1913 / DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, $ 1997 / DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, $ 3121 / DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, $ 997 / DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, $ 1833 / DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, $ 2877 / DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, $ 1633 / DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, $ 981 / DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, $ 2009 / DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, $ 941 / DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, $ 2449 / DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, $ 197 / DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, $ 2441 / DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, $ 285 / DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, $ 1473 / DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, $ 2741 / DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, $ 3129 / DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, $ 909 / DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, $ 2801 / DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, $ 421 / DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, $ 4073 / DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, $ 2813 / DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, $ 2337 / DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, $ 1429 / DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, $ 1177 / DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, $ 1901 / DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, $ 81 / DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, $ 1669 / DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, $ 2633 / DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, $ 2269 / DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, $ 129 / DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, $ 1141 / DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, $ 249 / DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, $ 3917 / DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, $ 2481 / DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, $ 3941 / DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, $ 2217 / DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, $ 2749 / DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, $ 3041 / DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, $ 1877 / DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, $ 345 / DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, $ 2861 / DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, $ 1809 / DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, $ 3141 / DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, $ 2825 / DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, $ 157 / DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, $ 2881 / DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, $ 3637 / DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, $ 1465 / DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, $ 2829 / DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, $ 2161 / DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, $ 3365 / DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, $ 361 / DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, $ 2685 / DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, $ 3745 / DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, $ 2325 / DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, $ 3609 / DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, $ 3821 / DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, $ 3537 / DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, $ 517 / DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, $ 3017 / DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, $ 2141 / DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, $ 1537 / * .. * .. Executable Statements .. * I1 = ISEED( 1 ) I2 = ISEED( 2 ) I3 = ISEED( 3 ) I4 = ISEED( 4 ) * DO 10 I = 1, MIN( N, LV ) * * Multiply the seed by i-th power of the multiplier modulo 2**48 * IT4 = I4*MM( I, 4 ) IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + $ I4*MM( I, 1 ) IT1 = MOD( IT1, IPW2 ) * * Convert 48-bit integer to a real number in the interval (0,1) * X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* $ DBLE( IT4 ) ) ) ) 10 CONTINUE * * Return final value of seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 RETURN * * End of DLARUV * END SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNM2L overwrites the general complex m-by-n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'C', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'C', * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(k) . . . H(2) H(1) * * as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'C': apply Q' (Conjugate transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGEQLF in the last k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQLF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the m-by-n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNM2L', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)' is applied to C(1:m-k+i,1:n) * MI = M - K + I ELSE * * H(i) or H(i)' is applied to C(1:m,1:n-k+i) * NI = N - K + I END IF * * Apply H(i) or H(i)' * IF( NOTRAN ) THEN TAUI = TAU( I ) ELSE TAUI = DCONJG( TAU( I ) ) END IF AII = A( NQ-K+I, I ) A( NQ-K+I, I ) = ONE CALL ZLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK ) A( NQ-K+I, I ) = AII 10 CONTINUE RETURN * * End of ZUNM2L * END SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNM2R overwrites the general complex m-by-n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'C', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'C', * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'C': apply Q' (Conjugate transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the m-by-n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)' * IF( NOTRAN ) THEN TAUI = TAU( I ) ELSE TAUI = DCONJG( TAU( I ) ) END IF AII = A( I, I ) A( I, I ) = ONE CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, $ WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of ZUNM2R * END SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DGETRF computes an LU factorization of a general M-by-N matrix A * using partial pivoting with row interchanges. * * The factorization has the form * A = P * L * U * where P is a permutation matrix, L is lower triangular with unit * diagonal elements (lower trapezoidal if m > n), and U is upper * triangular (upper trapezoidal if m < n). * * This is the right-looking Level 3 BLAS version of the algorithm. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the M-by-N matrix to be factored. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * IPIV (output) INTEGER array, dimension (min(M,N)) * The pivot indices; for 1 <= i <= min(M,N), row i of the * matrix was interchanged with row IPIV(i). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, IINFO, J, JB, NB * .. * .. External Subroutines .. EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRF', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN * * Use unblocked code. * CALL DGETF2( M, N, A, LDA, IPIV, INFO ) ELSE * * Use blocked code. * DO 20 J = 1, MIN( M, N ), NB JB = MIN( MIN( M, N )-J+1, NB ) * * Factor diagonal and subdiagonal blocks and test for exact * singularity. * CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) * * Adjust INFO and the pivot indices. * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO + J - 1 DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE * * Apply interchanges to columns 1:J-1. * CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) * IF( J+JB.LE.N ) THEN * * Apply interchanges to columns J+JB:N. * CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) * * Compute block row of U. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), $ LDA ) IF( J+JB.LE.M ) THEN * * Update trailing submatrix. * CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), $ LDA ) END IF END IF 20 CONTINUE END IF RETURN * * End of DGETRF * END SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DGETRI computes the inverse of a matrix using the LU factorization * computed by DGETRF. * * This method inverts U and then computes inv(A) by solving the system * inv(A)*L = inv(U) for inv(A). * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the factors L and U from the factorization * A = P*L*U as computed by DGETRF. * On exit, if INFO = 0, the inverse of the original matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (input) INTEGER array, dimension (N) * The pivot indices from DGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO=0, then WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimal performance LWORK >= N*NB, where NB is * the optimal blocksize returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero; the matrix is * singular and its inverse could not be computed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, $ NBMIN, NN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. External Subroutines .. EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRI', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form inv(U). If INFO > 0 from DTRTRI, then U is singular, * and the inverse is not computed. * CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) IF( INFO.GT.0 ) $ RETURN * NBMIN = 2 LDWORK = N IF( NB.GT.1 .AND. NB.LT.N ) THEN IWS = MAX( LDWORK*NB, 1 ) IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) END IF ELSE IWS = N END IF * * Solve the equation inv(A)*L = inv(U) for inv(A). * IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN * * Use unblocked code. * DO 20 J = N, 1, -1 * * Copy current column of L to WORK and replace with zeros. * DO 10 I = J + 1, N WORK( I ) = A( I, J ) A( I, J ) = ZERO 10 CONTINUE * * Compute current column of inv(A). * IF( J.LT.N ) $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) 20 CONTINUE ELSE * * Use blocked code. * NN = ( ( N-1 ) / NB )*NB + 1 DO 50 J = NN, 1, -NB JB = MIN( NB, N-J+1 ) * * Copy current block column of L to WORK and replace with * zeros. * DO 40 JJ = J, J + JB - 1 DO 30 I = JJ + 1, N WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) A( I, JJ ) = ZERO 30 CONTINUE 40 CONTINUE * * Compute current block column of inv(A). * IF( J+JB.LE.N ) $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) 50 CONTINUE END IF * * Apply column interchanges. * DO 60 J = N - 1, 1, -1 JP = IPIV( J ) IF( JP.NE.J ) $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) 60 CONTINUE * WORK( 1 ) = IWS RETURN * * End of DGETRI * END SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZPOTRF computes the Cholesky factorization of a complex Hermitian * positive definite matrix A. * * The factorization has the form * A = U**H * U, if UPLO = 'U', or * A = L * L**H, if UPLO = 'L', * where U is an upper triangular matrix and L is lower triangular. * * This is the block version of the algorithm, calling Level 3 BLAS. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the factor U or L from the Cholesky * factorization A = U**H*U or A = L*L**H. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, the leading minor of order i is not * positive definite, and the factorization could not be * completed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE COMPLEX*16 CONE PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, JB, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMM, ZHERK, ZPOTF2, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZPOTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code. * CALL ZPOTF2( UPLO, N, A, LDA, INFO ) ELSE * * Use blocked code. * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U'*U. * DO 10 J = 1, N, NB * * Update and factorize the current diagonal block and test * for non-positive-definiteness. * JB = MIN( NB, N-J+1 ) CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1, $ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA ) CALL ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) IF( INFO.NE.0 ) $ GO TO 30 IF( J+JB.LE.N ) THEN * * Compute the current block row. * CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB, $ N-J-JB+1, J-1, -CONE, A( 1, J ), LDA, $ A( 1, J+JB ), LDA, CONE, A( J, J+JB ), $ LDA ) CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose', $ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ), $ LDA, A( J, J+JB ), LDA ) END IF 10 CONTINUE * ELSE * * Compute the Cholesky factorization A = L*L'. * DO 20 J = 1, N, NB * * Update and factorize the current diagonal block and test * for non-positive-definiteness. * JB = MIN( NB, N-J+1 ) CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE, $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) CALL ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) IF( INFO.NE.0 ) $ GO TO 30 IF( J+JB.LE.N ) THEN * * Compute the current block column. * CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ), $ LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ), $ LDA ) CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose', $ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ), $ LDA, A( J+JB, J ), LDA ) END IF 20 CONTINUE END IF END IF GO TO 40 * 30 CONTINUE INFO = INFO + J - 1 * 40 CONTINUE RETURN * * End of ZPOTRF * END SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DGETF2 computes an LU factorization of a general m-by-n matrix A * using partial pivoting with row interchanges. * * The factorization has the form * A = P * L * U * where P is a permutation matrix, L is lower triangular with unit * diagonal elements (lower trapezoidal if m > n), and U is upper * triangular (upper trapezoidal if m < n). * * This is the right-looking Level 2 BLAS version of the algorithm. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the m by n matrix to be factored. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * IPIV (output) INTEGER array, dimension (min(M,N)) * The pivot indices; for 1 <= i <= min(M,N), row i of the * matrix was interchanged with row IPIV(i). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, U(k,k) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, JP * .. * .. External Functions .. INTEGER IDAMAX EXTERNAL IDAMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * DO 10 J = 1, MIN( M, N ) * * Find pivot and test for singularity. * JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) IPIV( J ) = JP IF( A( JP, J ).NE.ZERO ) THEN * * Apply the interchange to columns 1:N. * IF( JP.NE.J ) $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) * * Compute elements J+1:M of J-th column. * IF( J.LT.M ) $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) * ELSE IF( INFO.EQ.0 ) THEN * INFO = J END IF * IF( J.LT.MIN( M, N ) ) THEN * * Update trailing submatrix. * CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, $ A( J+1, J+1 ), LDA ) END IF 10 CONTINUE RETURN * * End of DGETF2 * END SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DLASWP performs a series of row interchanges on the matrix A. * One row interchange is initiated for each of rows K1 through K2 of A. * * Arguments * ========= * * N (input) INTEGER * The number of columns of the matrix A. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the matrix of column dimension N to which the row * interchanges will be applied. * On exit, the permuted matrix. * * LDA (input) INTEGER * The leading dimension of the array A. * * K1 (input) INTEGER * The first element of IPIV for which a row interchange will * be done. * * K2 (input) INTEGER * The last element of IPIV for which a row interchange will * be done. * * IPIV (input) INTEGER array, dimension (M*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. * * INCX (input) INTEGER * The increment between successive values of IPIV. If IPIV * is negative, the pivots are applied in reverse order. * * Further Details * =============== * * Modified by * R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 DOUBLE PRECISION TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = 1 + ( 1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF * N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF * RETURN * * End of DLASWP * END SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DTRTRI computes the inverse of a real upper or lower triangular * matrix A. * * This is the Level 3 BLAS version of the algorithm. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': A is upper triangular; * = 'L': A is lower triangular. * * DIAG (input) CHARACTER*1 * = 'N': A is non-unit triangular; * = 'U': A is unit triangular. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the triangular matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of the array A contains * the upper triangular matrix, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of the array A contains * the lower triangular matrix, and the strictly upper * triangular part of A is not referenced. If DIAG = 'U', the * diagonal elements of A are also not referenced and are * assumed to be 1. * On exit, the (triangular) inverse of the original matrix, in * the same storage format. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, A(i,i) is exactly zero. The triangular * matrix is singular and its inverse can not be computed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J, JB, NB, NN * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTRI', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Check for singularity if non-unit. * IF( NOUNIT ) THEN DO 10 INFO = 1, N IF( A( INFO, INFO ).EQ.ZERO ) $ RETURN 10 CONTINUE INFO = 0 END IF * * Determine the block size for this environment. * NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code * CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) ELSE * * Use blocked code * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix * DO 20 J = 1, N, NB JB = MIN( NB, N-J+1 ) * * Compute rows 1:j-1 of current block column * CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, $ JB, ONE, A, LDA, A( 1, J ), LDA ) CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) * * Compute inverse of current diagonal block * CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) 20 CONTINUE ELSE * * Compute inverse of lower triangular matrix * NN = ( ( N-1 ) / NB )*NB + 1 DO 30 J = NN, 1, -NB JB = MIN( NB, N-J+1 ) IF( J+JB.LE.N ) THEN * * Compute rows j+jb:n of current block column * CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, $ A( J+JB, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, $ A( J+JB, J ), LDA ) END IF * * Compute inverse of current diagonal block * CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) 30 CONTINUE END IF END IF * RETURN * * End of DTRTRI * END SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DTRTI2 computes the inverse of a real upper or lower triangular * matrix. * * This is the Level 2 BLAS version of the algorithm. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the matrix A is upper or lower triangular. * = 'U': Upper triangular * = 'L': Lower triangular * * DIAG (input) CHARACTER*1 * Specifies whether or not the matrix A is unit triangular. * = 'N': Non-unit triangular * = 'U': Unit triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the triangular matrix A. If UPLO = 'U', the * leading n by n upper triangular part of the array A contains * the upper triangular matrix, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n by n lower triangular part of the array A contains * the lower triangular matrix, and the strictly upper * triangular part of A is not referenced. If DIAG = 'U', the * diagonal elements of A are also not referenced and are * assumed to be 1. * * On exit, the (triangular) inverse of the original matrix, in * the same storage format. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DSCAL, DTRMV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTI2', -INFO ) RETURN END IF * IF( UPPER ) THEN * * Compute inverse of upper triangular matrix. * DO 10 J = 1, N IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF * * Compute elements 1:j-1 of j-th column. * CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, $ A( 1, J ), 1 ) CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) 10 CONTINUE ELSE * * Compute inverse of lower triangular matrix. * DO 20 J = N, 1, -1 IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN * * Compute elements j+1:n of j-th column. * CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF * RETURN * * End of DTRTI2 * END SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZPOTF2 computes the Cholesky factorization of a complex Hermitian * positive definite matrix A. * * The factorization has the form * A = U' * U , if UPLO = 'U', or * A = L * L', if UPLO = 'L', * where U is an upper triangular matrix and L is lower triangular. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * Hermitian matrix A is stored. * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the Hermitian matrix A. If UPLO = 'U', the leading * n by n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n by n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the factor U or L from the Cholesky * factorization A = U'*U or A = L*L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, the leading minor of order k is not * positive definite, and the factorization could not be * completed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME COMPLEX*16 ZDOTC EXTERNAL LSAME, ZDOTC * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZPOTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U'*U. * DO 10 J = 1, N * * Compute U(J,J) and test for non-positive-definiteness. * AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1, $ A( 1, J ), 1 ) IF( AJJ.LE.ZERO ) THEN A( J, J ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of row J. * IF( J.LT.N ) THEN CALL ZLACGV( J-1, A( 1, J ), 1 ) CALL ZGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ), $ LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA ) CALL ZLACGV( J-1, A( 1, J ), 1 ) CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) END IF 10 CONTINUE ELSE * * Compute the Cholesky factorization A = L*L'. * DO 20 J = 1, N * * Compute L(J,J) and test for non-positive-definiteness. * AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA, $ A( J, 1 ), LDA ) IF( AJJ.LE.ZERO ) THEN A( J, J ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of column J. * IF( J.LT.N ) THEN CALL ZLACGV( J-1, A( J, 1 ), LDA ) CALL ZGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ), $ LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 ) CALL ZLACGV( J-1, A( J, 1 ), LDA ) CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF GO TO 40 * 30 CONTINUE INFO = J * 40 CONTINUE RETURN * * End of ZPOTF2 * END SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, ITYPE, LDA, LDB, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) * .. * * Purpose * ======= * * DSYGV computes all the eigenvalues, and optionally, the eigenvectors * of a real generalized symmetric-definite eigenproblem, of the form * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. * Here A and B are assumed to be symmetric and B is also * positive definite. * * Arguments * ========= * * ITYPE (input) INTEGER * Specifies the problem type to be solved: * = 1: A*x = (lambda)*B*x * = 2: A*B*x = (lambda)*x * = 3: B*A*x = (lambda)*x * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangles of A and B are stored; * = 'L': Lower triangles of A and B are stored. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) * On entry, the symmetric matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * * On exit, if JOBZ = 'V', then if INFO = 0, A contains the * matrix Z of eigenvectors. The eigenvectors are normalized * as follows: * if ITYPE = 1 or 2, Z**T*B*Z = I; * if ITYPE = 3, Z**T*inv(B)*Z = I. * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') * or the lower triangle (if UPLO='L') of A, including the * diagonal, is destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) DOUBLE PRECISION array, dimension (LDB, N) * On entry, the symmetric positive definite matrix B. * If UPLO = 'U', the leading N-by-N upper triangular part of B * contains the upper triangular part of the matrix B. * If UPLO = 'L', the leading N-by-N lower triangular part of B * contains the lower triangular part of the matrix B. * * On exit, if INFO <= N, the part of B containing the matrix is * overwritten by the triangular factor U or L from the Cholesky * factorization B = U**T*U or B = L*L**T. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,3*N-1). * For optimal efficiency, LWORK >= (NB+2)*N, * where NB is the blocksize for DSYTRD returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: DPOTRF or DSYEV returned an error code: * <= N: if INFO = i, DSYEV failed to converge; * i off-diagonal elements of an intermediate * tridiagonal form did not converge to zero; * > N: if INFO = N + i, for 1 <= i <= N, then the leading * minor of order i of B is not positive definite. * The factorization of B could not be completed and * no eigenvalues or eigenvectors were computed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER, WANTZ CHARACTER TRANS INTEGER LWKOPT, NB, NEIG * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -11 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = ( NB+2 )*N WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Form a Cholesky factorization of B. * CALL DPOTRF( UPLO, N, B, LDB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * NEIG = N IF( INFO.GT.0 ) $ NEIG = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)'*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'T' END IF * CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, $ B, LDB, A, LDA ) * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U'*y * IF( UPPER ) THEN TRANS = 'T' ELSE TRANS = 'N' END IF * CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE, $ B, LDB, A, LDA ) END IF END IF * WORK( 1 ) = LWKOPT RETURN * * End of DSYGV * END SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DPOTRF computes the Cholesky factorization of a real symmetric * positive definite matrix A. * * The factorization has the form * A = U**T * U, if UPLO = 'U', or * A = L * L**T, if UPLO = 'L', * where U is an upper triangular matrix and L is lower triangular. * * This is the block version of the algorithm, calling Level 3 BLAS. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the factor U or L from the Cholesky * factorization A = U**T*U or A = L*L**T. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, the leading minor of order i is not * positive definite, and the factorization could not be * completed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J, JB, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code. * CALL DPOTF2( UPLO, N, A, LDA, INFO ) ELSE * * Use blocked code. * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U'*U. * DO 10 J = 1, N, NB * * Update and factorize the current diagonal block and test * for non-positive-definiteness. * JB = MIN( NB, N-J+1 ) CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) IF( INFO.NE.0 ) $ GO TO 30 IF( J+JB.LE.N ) THEN * * Compute the current block row. * CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), $ LDA, ONE, A( J, J+JB ), LDA ) CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', $ JB, N-J-JB+1, ONE, A( J, J ), LDA, $ A( J, J+JB ), LDA ) END IF 10 CONTINUE * ELSE * * Compute the Cholesky factorization A = L*L'. * DO 20 J = 1, N, NB * * Update and factorize the current diagonal block and test * for non-positive-definiteness. * JB = MIN( NB, N-J+1 ) CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) IF( INFO.NE.0 ) $ GO TO 30 IF( J+JB.LE.N ) THEN * * Compute the current block column. * CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), $ LDA, ONE, A( J+JB, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', $ N-J-JB+1, JB, ONE, A( J, J ), LDA, $ A( J+JB, J ), LDA ) END IF 20 CONTINUE END IF END IF GO TO 40 * 30 CONTINUE INFO = INFO + J - 1 * 40 CONTINUE RETURN * * End of DPOTRF * END SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) * .. * * Purpose * ======= * * DSYEV computes all eigenvalues and, optionally, eigenvectors of a * real symmetric matrix A. * * Arguments * ========= * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) * On entry, the symmetric matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * On exit, if JOBZ = 'V', then if INFO = 0, A contains the * orthonormal eigenvectors of the matrix A. * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') * or the upper triangle (if UPLO='U') of A, including the * diagonal, is destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * W (output) DOUBLE PRECISION array, dimension (N) * If INFO = 0, the eigenvalues in ascending order. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,3*N-1). * For optimal efficiency, LWORK >= (NB+2)*N, * where NB is the blocksize for DSYTRD returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, the algorithm failed to converge; i * off-diagonal elements of an intermediate tridiagonal * form did not converge to zero. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LOWER, LQUERY, WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, $ LLWORK, LOPT, LWKOPT, NB DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * WANTZ = LSAME( JOBZ, 'V' ) LOWER = LSAME( UPLO, 'L' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = MAX( 1, ( NB+2 )*N ) WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN W( 1 ) = A( 1, 1 ) WORK( 1 ) = 3 IF( WANTZ ) $ A( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) * * Scale matrix to allowable range, if necessary. * ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) * * Call DSYTRD to reduce symmetric matrix to tridiagonal form. * INDE = 1 INDTAU = INDE + N INDWRK = INDTAU + N LLWORK = LWORK - INDWRK + 1 CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) LOPT = 2*N + WORK( INDWRK ) * * For eigenvalues only, call DSTERF. For eigenvectors, first call * DORGTR to generate the orthogonal matrix, then call DSTEQR. * IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), $ LLWORK, IINFO ) CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), $ INFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * Set WORK(1) to optimal workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of DSYEV * END SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, ITYPE, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DSYGST reduces a real symmetric-definite generalized eigenproblem * to standard form. * * If ITYPE = 1, the problem is A*x = lambda*B*x, * and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) * * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or * B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. * * B must have been previously factorized as U**T*U or L*L**T by DPOTRF. * * Arguments * ========= * * ITYPE (input) INTEGER * = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); * = 2 or 3: compute U*A*U**T or L**T*A*L. * * UPLO (input) CHARACTER * = 'U': Upper triangle of A is stored and B is factored as * U**T*U; * = 'L': Lower triangle of A is stored and B is factored as * L*L**T. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the transformed matrix, stored in the * same format as A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input) DOUBLE PRECISION array, dimension (LDB,N) * The triangular factor from the Cholesky factorization of B, * as returned by DPOTRF. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, HALF PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER K, KB, NB * .. * .. External Subroutines .. EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGST', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 ) * IF( NB.LE.1 .OR. NB.GE.N ) THEN * * Use unblocked code * CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) ELSE * * Use blocked code * IF( ITYPE.EQ.1 ) THEN IF( UPPER ) THEN * * Compute inv(U')*A*inv(U) * DO 10 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the upper triangle of A(k:n,k:n) * CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) IF( K+KB.LE.N ) THEN CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit', $ KB, N-K-KB+1, ONE, B( K, K ), LDB, $ A( K, K+KB ), LDA ) CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, $ A( K, K+KB ), LDA ) CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE, $ A( K, K+KB ), LDA, B( K, K+KB ), LDB, $ ONE, A( K+KB, K+KB ), LDA ) CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF, $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE, $ A( K, K+KB ), LDA ) CALL DTRSM( 'Right', UPLO, 'No transpose', $ 'Non-unit', KB, N-K-KB+1, ONE, $ B( K+KB, K+KB ), LDB, A( K, K+KB ), $ LDA ) END IF 10 CONTINUE ELSE * * Compute inv(L)*A*inv(L') * DO 20 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the lower triangle of A(k:n,k:n) * CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) IF( K+KB.LE.N ) THEN CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit', $ N-K-KB+1, KB, ONE, B( K, K ), LDB, $ A( K+KB, K ), LDA ) CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, $ A( K+KB, K ), LDA ) CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB, $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ), $ LDB, ONE, A( K+KB, K+KB ), LDA ) CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF, $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE, $ A( K+KB, K ), LDA ) CALL DTRSM( 'Left', UPLO, 'No transpose', $ 'Non-unit', N-K-KB+1, KB, ONE, $ B( K+KB, K+KB ), LDB, A( K+KB, K ), $ LDA ) END IF 20 CONTINUE END IF ELSE IF( UPPER ) THEN * * Compute U*A*U' * DO 30 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the upper triangle of A(1:k+kb-1,1:k+kb-1) * CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit', $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA ) CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE, $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A, $ LDA ) CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ), $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA ) CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit', $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ), $ LDA ) CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) 30 CONTINUE ELSE * * Compute L'*A*L * DO 40 K = 1, N, NB KB = MIN( N-K+1, NB ) * * Update the lower triangle of A(1:k+kb-1,1:k+kb-1) * CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA ) CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE, $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A, $ LDA ) CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ), $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA ) CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB, $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA ) CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA, $ B( K, K ), LDB, INFO ) 40 CONTINUE END IF END IF END IF RETURN * * End of DSYGST * END DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DLANSY returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * real symmetric matrix A. * * Description * =========== * * DLANSY returns the value * * DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in DLANSY as described * above. * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * symmetric matrix A is to be referenced. * = 'U': Upper triangular part of A is referenced * = 'L': Lower triangular part of A is referenced * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, DLANSY is * set to zero. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The symmetric matrix A. If UPLO = 'U', the leading n by n * upper triangular part of A contains the upper triangular part * of the matrix A, and the strictly lower triangular part of A * is not referenced. If UPLO = 'L', the leading n by n lower * triangular part of A contains the lower triangular part of * the matrix A, and the strictly upper triangular part of A is * not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, * WORK is not referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION ABSA, SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, J VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1, N DO 30 I = J, N VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 30 CONTINUE 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN * * Find normI(A) ( = norm1(A), since A is symmetric). * VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 50 CONTINUE WORK( J ) = SUM + ABS( A( J, J ) ) 60 CONTINUE DO 70 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( A( J, J ) ) DO 90 I = J + 1, N ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA 90 CONTINUE VALUE = MAX( VALUE, SUM ) 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF SUM = 2*SUM CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) VALUE = SCALE*SQRT( SUM ) END IF * DLANSY = VALUE RETURN * * End of DLANSY * END SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORGTR generates a real orthogonal matrix Q which is defined as the * product of n-1 elementary reflectors of order N, as returned by * DSYTRD: * * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), * * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A contains elementary reflectors * from DSYTRD; * = 'L': Lower triangle of A contains elementary reflectors * from DSYTRD. * * N (input) INTEGER * The order of the matrix Q. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the vectors which define the elementary reflectors, * as returned by DSYTRD. * On exit, the N-by-N orthogonal matrix Q. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (N-1) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DSYTRD. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N-1). * For optimum performance LWORK >= (N-1)*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER I, IINFO, J, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORGQL, DORGQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF * IF( INFO.EQ.0 ) THEN IF( UPPER ) THEN NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) ELSE NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) END IF LWKOPT = MAX( 1, N-1 )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGTR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( UPPER ) THEN * * Q was determined by a call to DSYTRD with UPLO = 'U' * * Shift the vectors which define the elementary reflectors one * column to the left, and set the last row and column of Q to * those of the unit matrix * DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 A( I, J ) = A( I, J+1 ) 10 CONTINUE A( N, J ) = ZERO 20 CONTINUE DO 30 I = 1, N - 1 A( I, N ) = ZERO 30 CONTINUE A( N, N ) = ONE * * Generate Q(1:n-1,1:n-1) * CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * Q was determined by a call to DSYTRD with UPLO = 'L'. * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first row and column of Q to * those of the unit matrix * DO 50 J = N, 2, -1 A( 1, J ) = ZERO DO 40 I = J + 1, N A( I, J ) = A( I, J-1 ) 40 CONTINUE 50 CONTINUE A( 1, 1 ) = ONE DO 60 I = 2, N A( I, 1 ) = ZERO 60 CONTINUE IF( N.GT.1 ) THEN * * Generate Q(2:n,2:n) * CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of DORGTR * END SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DPOTF2 computes the Cholesky factorization of a real symmetric * positive definite matrix A. * * The factorization has the form * A = U' * U , if UPLO = 'U', or * A = L * L', if UPLO = 'L', * where U is an upper triangular matrix and L is lower triangular. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored. * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * n by n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n by n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the factor U or L from the Cholesky * factorization A = U'*U or A = L*L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, the leading minor of order k is not * positive definite, and the factorization could not be * completed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER J DOUBLE PRECISION AJJ * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. External Subroutines .. EXTERNAL DGEMV, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Compute the Cholesky factorization A = U'*U. * DO 10 J = 1, N * * Compute U(J,J) and test for non-positive-definiteness. * AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) IF( AJJ.LE.ZERO ) THEN A( J, J ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of row J. * IF( J.LT.N ) THEN CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) END IF 10 CONTINUE ELSE * * Compute the Cholesky factorization A = L*L'. * DO 20 J = 1, N * * Compute L(J,J) and test for non-positive-definiteness. * AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), $ LDA ) IF( AJJ.LE.ZERO ) THEN A( J, J ) = AJJ GO TO 30 END IF AJJ = SQRT( AJJ ) A( J, J ) = AJJ * * Compute elements J+1:N of column J. * IF( J.LT.N ) THEN CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF GO TO 40 * 30 CONTINUE INFO = J * 40 CONTINUE RETURN * * End of DPOTF2 * END SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), $ WORK( * ) * .. * * Purpose * ======= * * DSYTRD reduces a real symmetric matrix A to real symmetric * tridiagonal form T by an orthogonal similarity transformation: * Q**T * A * Q = T. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * N-by-N upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading N-by-N lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit, if UPLO = 'U', the diagonal and first superdiagonal * of A are overwritten by the corresponding elements of the * tridiagonal matrix T, and the elements above the first * superdiagonal, with the array TAU, represent the orthogonal * matrix Q as a product of elementary reflectors; if UPLO * = 'L', the diagonal and first subdiagonal of A are over- * written by the corresponding elements of the tridiagonal * matrix T, and the elements below the first subdiagonal, with * the array TAU, represent the orthogonal matrix Q as a product * of elementary reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * D (output) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the tridiagonal matrix T: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (N-1) * The off-diagonal elements of the tridiagonal matrix T: * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. * * TAU (output) DOUBLE PRECISION array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 1. * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n-1) . . . H(2) H(1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in * A(1:i-1,i+1), and tau in TAU(i). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(n-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), * and tau in TAU(i). * * The contents of A on exit are illustrated by the following examples * with n = 5: * * if UPLO = 'U': if UPLO = 'L': * * ( d e v2 v3 v4 ) ( d ) * ( d e v3 v4 ) ( e d ) * ( d e v4 ) ( v1 e d ) * ( d e ) ( v1 v2 e d ) * ( d ) ( v1 v2 v3 e d ) * * where d and e denote diagonal and off-diagonal elements of T, and vi * denotes an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, UPPER INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. * NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NX = N IWS = 1 IF( NB.GT.1 .AND. NB.LT.N ) THEN * * Determine when to cross over from blocked to unblocked code * (last block is always handled by unblocked code). * NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) IF( NX.LT.N ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: determine the * minimum value of NB, and reduce NB or force use of * unblocked code by setting NX = N. * NB = MAX( LWORK / LDWORK, 1 ) NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) IF( NB.LT.NBMIN ) $ NX = N END IF ELSE NX = N END IF ELSE NB = 1 END IF * IF( UPPER ) THEN * * Reduce the upper triangle of A. * Columns 1:kk are handled by the unblocked method. * KK = N - ( ( N-NX+NB-1 ) / NB )*NB DO 20 I = N - NB + 1, KK + 1, -NB * * Reduce columns i:i+nb-1 to tridiagonal form and form the * matrix W which is needed to update the unreduced part of * the matrix * CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, $ LDWORK ) * * Update the unreduced submatrix A(1:i-1,1:i-1), using an * update of the form: A := A - V*W' - W*V' * CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), $ LDA, WORK, LDWORK, ONE, A, LDA ) * * Copy superdiagonal elements back into A, and diagonal * elements into D * DO 10 J = I, I + NB - 1 A( J-1, J ) = E( J-1 ) D( J ) = A( J, J ) 10 CONTINUE 20 CONTINUE * * Use unblocked code to reduce the last or only block * CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) ELSE * * Reduce the lower triangle of A * DO 40 I = 1, N - NX, NB * * Reduce columns i:i+nb-1 to tridiagonal form and form the * matrix W which is needed to update the unreduced part of * the matrix * CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), $ TAU( I ), WORK, LDWORK ) * * Update the unreduced submatrix A(i+ib:n,i+ib:n), using * an update of the form: A := A - V*W' - W*V' * CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, $ A( I+NB, I+NB ), LDA ) * * Copy subdiagonal elements back into A, and diagonal * elements into D * DO 30 J = I, I + NB - 1 A( J+1, J ) = E( J ) D( J ) = A( J, J ) 30 CONTINUE 40 CONTINUE * * Use unblocked code to reduce the last or only block * CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAU( I ), IINFO ) END IF * WORK( 1 ) = LWKOPT RETURN * * End of DSYTRD * END SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDW, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) * .. * * Purpose * ======= * * DLATRD reduces NB rows and columns of a real symmetric matrix A to * symmetric tridiagonal form by an orthogonal similarity * transformation Q' * A * Q, and returns the matrices V and W which are * needed to apply the transformation to the unreduced part of A. * * If UPLO = 'U', DLATRD reduces the last NB rows and columns of a * matrix, of which the upper triangle is supplied; * if UPLO = 'L', DLATRD reduces the first NB rows and columns of a * matrix, of which the lower triangle is supplied. * * This is an auxiliary routine called by DSYTRD. * * Arguments * ========= * * UPLO (input) CHARACTER * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored: * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. * * NB (input) INTEGER * The number of rows and columns to be reduced. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * n-by-n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n-by-n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit: * if UPLO = 'U', the last NB columns have been reduced to * tridiagonal form, with the diagonal elements overwriting * the diagonal elements of A; the elements above the diagonal * with the array TAU, represent the orthogonal matrix Q as a * product of elementary reflectors; * if UPLO = 'L', the first NB columns have been reduced to * tridiagonal form, with the diagonal elements overwriting * the diagonal elements of A; the elements below the diagonal * with the array TAU, represent the orthogonal matrix Q as a * product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= (1,N). * * E (output) DOUBLE PRECISION array, dimension (N-1) * If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal * elements of the last NB columns of the reduced matrix; * if UPLO = 'L', E(1:nb) contains the subdiagonal elements of * the first NB columns of the reduced matrix. * * TAU (output) DOUBLE PRECISION array, dimension (N-1) * The scalar factors of the elementary reflectors, stored in * TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. * See Further Details. * * W (output) DOUBLE PRECISION array, dimension (LDW,NB) * The n-by-nb matrix W required to update the unreduced part * of A. * * LDW (input) INTEGER * The leading dimension of the array W. LDW >= max(1,N). * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n) H(n-1) . . . H(n-nb+1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), * and tau in TAU(i-1). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(nb). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), * and tau in TAU(i). * * The elements of the vectors v together form the n-by-nb matrix V * which is needed, with W, to apply the transformation to the unreduced * part of the matrix, using a symmetric rank-2k update of the form: * A := A - V*W' - W*V'. * * The contents of A on exit are illustrated by the following examples * with n = 5 and nb = 2: * * if UPLO = 'U': if UPLO = 'L': * * ( a a a v4 v5 ) ( d ) * ( a a v4 v5 ) ( 1 d ) * ( a 1 v5 ) ( v1 1 a ) * ( d 1 ) ( v1 v2 a a ) * ( d ) ( v1 v2 a a a ) * * where d denotes a diagonal element of the reduced matrix, a denotes * an element of the original matrix that is unchanged, and vi denotes * an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) * .. * .. Local Scalars .. INTEGER I, IW DOUBLE PRECISION ALPHA * .. * .. External Subroutines .. EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( LSAME( UPLO, 'U' ) ) THEN * * Reduce last NB columns of upper triangle * DO 10 I = N, N - NB + 1, -1 IW = I - N + NB IF( I.LT.N ) THEN * * Update A(1:i,i) * CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) END IF IF( I.GT.1 ) THEN * * Generate elementary reflector H(i) to annihilate * A(1:i-2,i) * CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) E( I-1 ) = A( I-1, I ) A( I-1, I ) = ONE * * Compute W(1:i-1,i) * CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, $ ZERO, W( 1, IW ), 1 ) IF( I.LT.N ) THEN CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, $ W( 1, IW ), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, -ONE, $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, $ W( 1, IW ), 1 ) END IF CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, $ A( 1, I ), 1 ) CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) END IF * 10 CONTINUE ELSE * * Reduce first NB columns of lower triangle * DO 20 I = 1, NB * * Update A(i:n,i) * CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) IF( I.LT.N ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:n,i) * CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) E( I ) = A( I+1, I ) A( I+1, I ) = ONE * * Compute W(i+1:n,i) * CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, $ A( I+1, I ), 1 ) CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) END IF * 20 CONTINUE END IF * RETURN * * End of DLATRD * END SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORGQL generates an M-by-N real matrix Q with orthonormal columns, * which is defined as the last N columns of a product of K elementary * reflectors of order M * * Q = H(k) . . . H(2) H(1) * * as returned by DGEQLF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the (n-k+i)-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by DGEQLF in the last k columns of its array * argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQLF. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, $ NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the first block. * The last kk columns are handled by the block method. * KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) * * Set A(m-kk+1:m,1:n-kk) to zero. * DO 20 J = 1, N - KK DO 10 I = M - KK + 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the first or only block. * CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = K - KK + 1, K, NB IB = MIN( NB, K-I+1 ) IF( N-K+I.GT.1 ) THEN * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left * CALL DLARFB( 'Left', 'No transpose', 'Backward', $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, $ WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows 1:m-k+i+ib-1 of current block * CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, $ TAU( I ), WORK, IINFO ) * * Set rows m-k+i+ib:m of current block to zero * DO 40 J = N - K + I, N - K + I + IB - 1 DO 30 L = M - K + I + IB, M A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGQL * END SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORGQR generates an M-by-N real matrix Q with orthonormal columns, * which is defined as the first N columns of a product of K elementary * reflectors of order M * * Q = H(1) H(2) . . . H(k) * * as returned by DGEQRF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. M >= N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. N >= K >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the i-th column must contain the vector which * defines the elementary reflector H(i), for i = 1,2,...,k, as * returned by DGEQRF in the first k columns of its array * argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, N )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORGQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk columns are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(1:kk,kk+1:n) to zero. * DO 20 J = KK + 1, N DO 10 I = 1, KK A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.N ) $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i:m,i+ib:n) from the left * CALL DLARFB( 'Left', 'No transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF * * Apply H to rows i:m of current block * CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set rows 1:i-1 of current block to zero * DO 40 J = I, I + IB - 1 DO 30 L = 1, I - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of DORGQR * END SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, ITYPE, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DSYGS2 reduces a real symmetric-definite generalized eigenproblem * to standard form. * * If ITYPE = 1, the problem is A*x = lambda*B*x, * and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') * * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or * B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. * * B must have been previously factorized as U'*U or L*L' by DPOTRF. * * Arguments * ========= * * ITYPE (input) INTEGER * = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); * = 2 or 3: compute U*A*U' or L'*A*L. * * UPLO (input) CHARACTER * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored, and how B has been factorized. * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * n by n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n by n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * * On exit, if INFO = 0, the transformed matrix, stored in the * same format as A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input) DOUBLE PRECISION array, dimension (LDB,N) * The triangular factor from the Cholesky factorization of B, * as returned by DPOTRF. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, HALF PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER K DOUBLE PRECISION AKK, BKK, CT * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGS2', -INFO ) RETURN END IF * IF( ITYPE.EQ.1 ) THEN IF( UPPER ) THEN * * Compute inv(U')*A*inv(U) * DO 10 K = 1, N * * Update the upper triangle of A(k:n,k:n) * AKK = A( K, K ) BKK = B( K, K ) AKK = AKK / BKK**2 A( K, K ) = AKK IF( K.LT.N ) THEN CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA ) CT = -HALF*AKK CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), $ LDA ) CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA, $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA ) CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ), $ LDA ) CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K, $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA ) END IF 10 CONTINUE ELSE * * Compute inv(L)*A*inv(L') * DO 20 K = 1, N * * Update the lower triangle of A(k:n,k:n) * AKK = A( K, K ) BKK = B( K, K ) AKK = AKK / BKK**2 A( K, K ) = AKK IF( K.LT.N ) THEN CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 ) CT = -HALF*AKK CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1, $ B( K+1, K ), 1, A( K+1, K+1 ), LDA ) CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 ) CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K, $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 ) END IF 20 CONTINUE END IF ELSE IF( UPPER ) THEN * * Compute U*A*U' * DO 30 K = 1, N * * Update the upper triangle of A(1:k,1:k) * AKK = A( K, K ) BKK = B( K, K ) CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B, $ LDB, A( 1, K ), 1 ) CT = HALF*AKK CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1, $ A, LDA ) CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 ) CALL DSCAL( K-1, BKK, A( 1, K ), 1 ) A( K, K ) = AKK*BKK**2 30 CONTINUE ELSE * * Compute L'*A*L * DO 40 K = 1, N * * Update the lower triangle of A(1:k,1:k) * AKK = A( K, K ) BKK = B( K, K ) CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB, $ A( K, 1 ), LDA ) CT = HALF*AKK CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ), $ LDB, A, LDA ) CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA ) CALL DSCAL( K-1, BKK, A( K, 1 ), LDA ) A( K, K ) = AKK*BKK**2 40 CONTINUE END IF END IF RETURN * * End of DSYGS2 * END SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) * .. * * Purpose * ======= * * DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal * form T by an orthogonal similarity transformation: Q' * A * Q = T. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the upper or lower triangular part of the * symmetric matrix A is stored: * = 'U': Upper triangular * = 'L': Lower triangular * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the symmetric matrix A. If UPLO = 'U', the leading * n-by-n upper triangular part of A contains the upper * triangular part of the matrix A, and the strictly lower * triangular part of A is not referenced. If UPLO = 'L', the * leading n-by-n lower triangular part of A contains the lower * triangular part of the matrix A, and the strictly upper * triangular part of A is not referenced. * On exit, if UPLO = 'U', the diagonal and first superdiagonal * of A are overwritten by the corresponding elements of the * tridiagonal matrix T, and the elements above the first * superdiagonal, with the array TAU, represent the orthogonal * matrix Q as a product of elementary reflectors; if UPLO * = 'L', the diagonal and first subdiagonal of A are over- * written by the corresponding elements of the tridiagonal * matrix T, and the elements below the first subdiagonal, with * the array TAU, represent the orthogonal matrix Q as a product * of elementary reflectors. See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * D (output) DOUBLE PRECISION array, dimension (N) * The diagonal elements of the tridiagonal matrix T: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (N-1) * The off-diagonal elements of the tridiagonal matrix T: * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. * * TAU (output) DOUBLE PRECISION array, dimension (N-1) * The scalar factors of the elementary reflectors (see Further * Details). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * If UPLO = 'U', the matrix Q is represented as a product of elementary * reflectors * * Q = H(n-1) . . . H(2) H(1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in * A(1:i-1,i+1), and tau in TAU(i). * * If UPLO = 'L', the matrix Q is represented as a product of elementary * reflectors * * Q = H(1) H(2) . . . H(n-1). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), * and tau in TAU(i). * * The contents of A on exit are illustrated by the following examples * with n = 5: * * if UPLO = 'U': if UPLO = 'L': * * ( d e v2 v3 v4 ) ( d ) * ( d e v3 v4 ) ( e d ) * ( d e v4 ) ( v1 e d ) * ( d e ) ( v1 v2 e d ) * ( d ) ( v1 v2 v3 e d ) * * where d and e denote diagonal and off-diagonal elements of T, and vi * denotes an element of the vector defining H(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO, HALF PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, $ HALF = 1.0D0 / 2.0D0 ) * .. * .. Local Scalars .. LOGICAL UPPER INTEGER I DOUBLE PRECISION ALPHA, TAUI * .. * .. External Subroutines .. EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYTD2', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.0 ) $ RETURN * IF( UPPER ) THEN * * Reduce the upper triangle of A * DO 10 I = N - 1, 1, -1 * * Generate elementary reflector H(i) = I - tau * v * v' * to annihilate A(1:i-1,i+1) * CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) E( I ) = A( I, I+1 ) * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(1:i,1:i) * A( I, I+1 ) = ONE * * Compute x := tau * A * v storing x in TAU(1:i) * CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, $ TAU, 1 ) * * Compute w := x - 1/2 * tau * (x'*v) * v * ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w' - w * v' * CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, $ LDA ) * A( I, I+1 ) = E( I ) END IF D( I+1 ) = A( I+1, I+1 ) TAU( I ) = TAUI 10 CONTINUE D( 1 ) = A( 1, 1 ) ELSE * * Reduce the lower triangle of A * DO 20 I = 1, N - 1 * * Generate elementary reflector H(i) = I - tau * v * v' * to annihilate A(i+2:n,i) * CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAUI ) E( I ) = A( I+1, I ) * IF( TAUI.NE.ZERO ) THEN * * Apply H(i) from both sides to A(i+1:n,i+1:n) * A( I+1, I ) = ONE * * Compute x := tau * A * v storing y in TAU(i:n-1) * CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) * * Compute w := x - 1/2 * tau * (x'*v) * v * ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), $ 1 ) CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) * * Apply the transformation as a rank-2 update: * A := A - v * w' - w * v' * CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, $ A( I+1, I+1 ), LDA ) * A( I+1, I ) = E( I ) END IF D( I ) = A( I, I ) TAU( I ) = TAUI 20 CONTINUE D( N ) = A( N, N ) END IF * RETURN * * End of DSYTD2 * END SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, $ T, LDT, C, LDC, WORK, LDWORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER K, LDC, LDT, LDV, LDWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), $ WORK( LDWORK, * ) * .. * * Purpose * ======= * * DLARFB applies a real block reflector H or its transpose H' to a * real m by n matrix C, from either the left or the right. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply H or H' from the Left * = 'R': apply H or H' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply H (No transpose) * = 'T': apply H' (Transpose) * * DIRECT (input) CHARACTER*1 * Indicates how H is formed from a product of elementary * reflectors * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Indicates how the vectors which define the elementary * reflectors are stored: * = 'C': Columnwise * = 'R': Rowwise * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * K (input) INTEGER * The order of the matrix T (= the number of elementary * reflectors whose product defines the block reflector). * * V (input) DOUBLE PRECISION array, dimension * (LDV,K) if STOREV = 'C' * (LDV,M) if STOREV = 'R' and SIDE = 'L' * (LDV,N) if STOREV = 'R' and SIDE = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); * if STOREV = 'R', LDV >= K. * * T (input) DOUBLE PRECISION array, dimension (LDT,K) * The triangular k by k matrix T in the representation of the * block reflector. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by H*C or H'*C or C*H or C*H'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) * * LDWORK (input) INTEGER * The leading dimension of the array WORK. * If SIDE = 'L', LDWORK >= max(1,N); * if SIDE = 'R', LDWORK >= max(1,M). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. CHARACTER TRANST INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DTRMM * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( LSAME( TRANS, 'N' ) ) THEN TRANST = 'T' ELSE TRANST = 'N' END IF * IF( LSAME( STOREV, 'C' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 ) (first K rows) * ( V2 ) * where V1 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C1' * DO 10 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 10 CONTINUE * * W := W * V1 * CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2 * 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' or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2 * W' * 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' * CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 30 J = 1, K DO 20 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 20 CONTINUE 30 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C1 * DO 40 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 40 CONTINUE * * W := W * V1 * 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', 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' * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C2 := C2 - W * V2' * 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' * 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, M C( I, J ) = C( I, J ) - WORK( I, J ) 50 CONTINUE 60 CONTINUE END IF * ELSE * * Let V = ( V1 ) * ( V2 ) (last K rows) * where V2 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) * * W := C2' * DO 70 J = 1, K 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', N, $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C1'*V1 * CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1 * W' * CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) END IF * * W := W * V2' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W' * DO 90 J = 1, K 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' where C = ( C1 C2 ) * * W := C * V = (C1*V1 + C2*V2) (stored in WORK) * * W := C2 * DO 100 J = 1, K 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', 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', M, K, N-K, $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T or W * T' * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V' * IF( N.GT.K ) THEN * * C1 := C1 - W * V1' * CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) END IF * * W := W * V2' * 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, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 110 CONTINUE 120 CONTINUE END IF END IF * ELSE IF( LSAME( STOREV, 'R' ) ) THEN * IF( LSAME( DIRECT, 'F' ) ) THEN * * Let V = ( V1 V2 ) (V1: first K columns) * where V1 is unit upper triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C1' * DO 130 J = 1, K CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) 130 CONTINUE * * W := W * V1' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, V, LDV, WORK, LDWORK ) IF( M.GT.K ) THEN * * W := W + C2'*V2' * 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' or W * T * CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C2 := C2 - V2' * W' * 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', N, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W' * DO 150 J = 1, K DO 140 I = 1, N C( J, I ) = C( J, I ) - WORK( I, J ) 140 CONTINUE 150 CONTINUE * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form C * H or C * H' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C1 * DO 160 J = 1, K CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) 160 CONTINUE * * W := W * V1' * CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, $ ONE, V, LDV, WORK, LDWORK ) IF( N.GT.K ) THEN * * W := W + C2 * V2' * 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' * CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C2 := C2 - W * V2 * 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', M, $ K, ONE, V, LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 180 J = 1, K DO 170 I = 1, M C( I, J ) = C( I, J ) - WORK( I, J ) 170 CONTINUE 180 CONTINUE * END IF * ELSE * * Let V = ( V1 V2 ) (V2: last K columns) * where V2 is unit lower triangular. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C or H' * C where C = ( C1 ) * ( C2 ) * * W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) * * W := C2' * DO 190 J = 1, K CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) 190 CONTINUE * * W := W * V2' * 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'*V1' * CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ C, LDC, V, LDV, ONE, WORK, LDWORK ) END IF * * W := W * T' or W * T * CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - V' * W' * IF( M.GT.K ) THEN * * C1 := C1 - V1' * W' * 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', N, $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) * * C2 := C2 - W' * DO 210 J = 1, K 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' where C = ( C1 C2 ) * * W := C * V' = (C1*V1' + C2*V2') (stored in WORK) * * W := C2 * DO 220 J = 1, K CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) 220 CONTINUE * * W := W * V2' * 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' * 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' * CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, $ ONE, T, LDT, WORK, LDWORK ) * * C := C - W * V * IF( N.GT.K ) THEN * * C1 := C1 - W * V1 * 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', M, $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) * * C1 := C1 - W * DO 240 J = 1, K DO 230 I = 1, M C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) 230 CONTINUE 240 CONTINUE * END IF * END IF END IF * RETURN * * End of DLARFB * END SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER K, LDT, LDV, N * .. * .. Array Arguments .. DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. * * Purpose * ======= * * DLARFT forms the triangular factor T of a real block reflector H * of order n, which is defined as a product of k elementary reflectors. * * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; * * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. * * If STOREV = 'C', the vector which defines the elementary reflector * H(i) is stored in the i-th column of the array V, and * * H = I - V * T * V' * * If STOREV = 'R', the vector which defines the elementary reflector * H(i) is stored in the i-th row of the array V, and * * H = I - V' * T * V * * Arguments * ========= * * DIRECT (input) CHARACTER*1 * Specifies the order in which the elementary reflectors are * multiplied to form the block reflector: * = 'F': H = H(1) H(2) . . . H(k) (Forward) * = 'B': H = H(k) . . . H(2) H(1) (Backward) * * STOREV (input) CHARACTER*1 * Specifies how the vectors which define the elementary * reflectors are stored (see also Further Details): * = 'C': columnwise * = 'R': rowwise * * N (input) INTEGER * The order of the block reflector H. N >= 0. * * K (input) INTEGER * The order of the triangular factor T (= the number of * elementary reflectors). K >= 1. * * V (input/output) DOUBLE PRECISION array, dimension * (LDV,K) if STOREV = 'C' * (LDV,N) if STOREV = 'R' * The matrix V. See further details. * * LDV (input) INTEGER * The leading dimension of the array V. * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i). * * T (output) DOUBLE PRECISION array, dimension (LDT,K) * The k by k triangular factor T of the block reflector. * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is * lower triangular. The rest of the array is not used. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= K. * * Further Details * =============== * * The shape of the matrix V and the storage of the vectors which define * the H(i) is best illustrated by the following example with n = 5 and * k = 3. The elements equal to 1 are not stored; the corresponding * array elements are modified but restored on exit. The rest of the * array is not used. * * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': * * V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) * ( v1 1 ) ( 1 v2 v2 v2 ) * ( v1 v2 1 ) ( 1 v3 v3 ) * ( v1 v2 v3 ) * ( v1 v2 v3 ) * * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': * * V = ( v1 v2 v3 ) V = ( v1 v1 1 ) * ( v1 v2 v3 ) ( v2 v2 v2 1 ) * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) * ( 1 v3 ) * ( 1 ) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION VII * .. * .. External Subroutines .. EXTERNAL DGEMV, DTRMV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 I = 1, K IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 10 J = 1, I T( J, I ) = ZERO 10 CONTINUE ELSE * * general case * VII = V( I, I ) V( I, I ) = ONE IF( LSAME( STOREV, 'C' ) ) THEN * * T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) * CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, $ T( 1, I ), 1 ) ELSE * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' * CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, $ T( 1, I ), 1 ) END IF V( I, I ) = VII * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, $ LDT, T( 1, I ), 1 ) T( I, I ) = TAU( I ) END IF 20 CONTINUE ELSE DO 40 I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * DO 30 J = I, K T( J, I ) = ZERO 30 CONTINUE ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN VII = V( N-K+I, I ) V( N-K+I, I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) * CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, $ T( I+1, I ), 1 ) V( N-K+I, I ) = VII ELSE VII = V( I, N-K+I ) V( I, N-K+I ) = ONE * * T(i+1:k,i) := * - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' * CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, $ T( I+1, I ), 1 ) V( I, N-K+I ) = VII END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) * CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) END IF T( I, I ) = TAU( I ) END IF 40 CONTINUE END IF RETURN * * End of DLARFT * END SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DPOTRS solves a system of linear equations A*X = B with a symmetric * positive definite matrix A using the Cholesky factorization * A = U**T*U or A = L*L**T computed by DPOTRF. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The triangular factor U or L from the Cholesky factorization * A = U**T*U or A = L*L**T, as computed by DPOTRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL UPPER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPOTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( UPPER ) THEN * * Solve A*X = B where A = U'*U. * * Solve U'*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve U*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) ELSE * * Solve A*X = B where A = L*L'. * * Solve L*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) * * Solve L'*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, $ ONE, A, LDA, B, LDB ) END IF * RETURN * * End of DPOTRS * END SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZGESV computes the solution to a complex system of linear equations * A * X = B, * where A is an N-by-N matrix and X and B are N-by-NRHS matrices. * * The LU decomposition with partial pivoting and row interchanges is * used to factor A as * A = P * L * U, * where P is a permutation matrix, L is unit lower triangular, and U is * upper triangular. The factored form of A is then used to solve the * system of equations A * X = B. * * Arguments * ========= * * N (input) INTEGER * The number of linear equations, i.e., the order of the * matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the N-by-N coefficient matrix A. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (output) INTEGER array, dimension (N) * The pivot indices that define the permutation matrix P; * row i of the matrix was interchanged with row IPIV(i). * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) * On entry, the N-by-NRHS matrix of right hand side matrix B. * On exit, if INFO = 0, the N-by-NRHS solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, so the solution could not be computed. * * ===================================================================== * * .. External Subroutines .. EXTERNAL XERBLA, ZGETRF, ZGETRS * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESV ', -INFO ) RETURN END IF * * Compute the LU factorization of A. * CALL ZGETRF( N, N, A, LDA, IPIV, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) END IF RETURN * * End of ZGESV * END SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBVL, JOBVR INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * Purpose * ======= * * ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices * (A,B), the generalized eigenvalues, and optionally, the left and/or * right generalized eigenvectors. * * A generalized eigenvalue for a pair of matrices (A,B) is a scalar * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is * singular. It is usually represented as the pair (alpha,beta), as * there is a reasonable interpretation for beta=0, and even for both * being zero. * * The right generalized eigenvector v(j) corresponding to the * generalized eigenvalue lambda(j) of (A,B) satisfies * * A * v(j) = lambda(j) * B * v(j). * * The left generalized eigenvector u(j) corresponding to the * generalized eigenvalues lambda(j) of (A,B) satisfies * * u(j)**H * A = lambda(j) * u(j)**H * B * * where u(j)**H is the conjugate-transpose of u(j). * * Arguments * ========= * * JOBVL (input) CHARACTER*1 * = 'N': do not compute the left generalized eigenvectors; * = 'V': compute the left generalized eigenvectors. * * JOBVR (input) CHARACTER*1 * = 'N': do not compute the right generalized eigenvectors; * = 'V': compute the right generalized eigenvectors. * * N (input) INTEGER * The order of the matrices A, B, VL, and VR. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) * On entry, the matrix A in the pair (A,B). * On exit, A has been overwritten. * * LDA (input) INTEGER * The leading dimension of A. LDA >= max(1,N). * * B (input/output) COMPLEX*16 array, dimension (LDB, N) * On entry, the matrix B in the pair (A,B). * On exit, B has been overwritten. * * LDB (input) INTEGER * The leading dimension of B. LDB >= max(1,N). * * ALPHA (output) COMPLEX*16 array, dimension (N) * BETA (output) COMPLEX*16 array, dimension (N) * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the * generalized eigenvalues. * * Note: the quotients ALPHA(j)/BETA(j) may easily over- or * underflow, and BETA(j) may even be zero. Thus, the user * should avoid naively computing the ratio alpha/beta. * However, ALPHA will be always less than and usually * comparable with norm(A) in magnitude, and BETA always less * than and usually comparable with norm(B). * * VL (output) COMPLEX*16 array, dimension (LDVL,N) * If JOBVL = 'V', the left generalized eigenvectors u(j) are * stored one after another in the columns of VL, in the same * order as their eigenvalues. * Each eigenvector will be scaled so the largest component * will have abs(real part) + abs(imag. part) = 1. * Not referenced if JOBVL = 'N'. * * LDVL (input) INTEGER * The leading dimension of the matrix VL. LDVL >= 1, and * if JOBVL = 'V', LDVL >= N. * * VR (output) COMPLEX*16 array, dimension (LDVR,N) * If JOBVR = 'V', the right generalized eigenvectors v(j) are * stored one after another in the columns of VR, in the same * order as their eigenvalues. * Each eigenvector will be scaled so the largest component * will have abs(real part) + abs(imag. part) = 1. * Not referenced if JOBVR = 'N'. * * LDVR (input) INTEGER * The leading dimension of the matrix VR. LDVR >= 1, and * if JOBVR = 'V', LDVR >= N. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,2*N). * For good performance, LWORK must generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * =1,...,N: * The QZ iteration failed. No eigenvectors have been * calculated, but ALPHA(j) and BETA(j) should be * correct for j=INFO+1,...,N. * > N: =N+1: other then QZ iteration failed in DHGEQZ, * =N+2: error return from DTGEVC. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY CHARACTER CHTEMP INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO, $ IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR, $ LWKMIN, LWKOPT DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SMLNUM, TEMP COMPLEX*16 X * .. * .. Local Arrays .. LOGICAL LDUMMA( 1 ) * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD, ZHGEQZ, $ ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR, ZUNMQR * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION ABS1 * .. * .. Statement Function definitions .. ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVL, 'N' ) ) THEN IJOBVL = 1 ILVL = .FALSE. ELSE IF( LSAME( JOBVL, 'V' ) ) THEN IJOBVL = 2 ILVL = .TRUE. ELSE IJOBVL = -1 ILVL = .FALSE. END IF * IF( LSAME( JOBVR, 'N' ) ) THEN IJOBVR = 1 ILVR = .FALSE. ELSE IF( LSAME( JOBVR, 'V' ) ) THEN IJOBVR = 2 ILVR = .TRUE. ELSE IJOBVR = -1 ILVR = .FALSE. END IF ILV = ILVL .OR. ILVR * * Test the input arguments * INFO = 0 LQUERY = ( LWORK.EQ.-1 ) IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN INFO = -11 ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN INFO = -13 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * NB refers to the optimal block size for the immediately * following subroutine, as returned by ILAENV. The workspace is * computed assuming ILO = 1 and IHI = N, the worst case.) * LWKMIN = 1 IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN LWKOPT = N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) LWKMIN = MAX( 1, 2*N ) WORK( 1 ) = LWKOPT END IF * IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) $ INFO = -15 * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGEV ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * WORK( 1 ) = LWKOPT IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK ) ILASCL = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ANRMTO = SMLNUM ILASCL = .TRUE. ELSE IF( ANRM.GT.BIGNUM ) THEN ANRMTO = BIGNUM ILASCL = .TRUE. END IF IF( ILASCL ) $ CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR ) * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF IF( ILBSCL ) $ CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR ) * * Permute the matrices A, B to isolate eigenvalues if possible * (Real Workspace: need 6*N) * ILEFT = 1 IRIGHT = N + 1 IRWRK = IRIGHT + N CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), RWORK( IRWRK ), IERR ) * * Reduce B to triangular form (QR decomposition of B) * (Complex Workspace: need N, prefer N*NB) * IROWS = IHI + 1 - ILO IF( ILV ) THEN ICOLS = N + 1 - ILO ELSE ICOLS = IROWS END IF ITAU = 1 IWRK = ITAU + IROWS CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWRK ), LWORK+1-IWRK, IERR ) * * Apply the orthogonal transformation to matrix A * (Complex Workspace: need N, prefer N*NB) * CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ), $ LWORK+1-IWRK, IERR ) * * Initialize VL * (Complex Workspace: need N, prefer N*NB) * IF( ILVL ) THEN CALL ZLASET( 'Full', N, N, CZERO, CONE, VL, LDVL ) CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VL( ILO+1, ILO ), LDVL ) CALL ZUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL, $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR ) END IF * * Initialize VR * IF( ILVR ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, VR, LDVR ) * * Reduce to generalized Hessenberg form * IF( ILV ) THEN * * Eigenvectors requested -- work on whole matrix. * CALL ZGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL, $ LDVL, VR, LDVR, IERR ) ELSE CALL ZGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA, $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR ) END IF * * Perform QZ algorithm (Compute eigenvalues, and optionally, the * Schur form and Schur vectors) * (Complex Workspace: need N) * (Real Workspace: need N) * IWRK = ITAU IF( ILV ) THEN CHTEMP = 'S' ELSE CHTEMP = 'E' END IF CALL ZHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ), $ LWORK+1-IWRK, RWORK( IRWRK ), IERR ) IF( IERR.NE.0 ) THEN IF( IERR.GT.0 .AND. IERR.LE.N ) THEN INFO = IERR ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN INFO = IERR - N ELSE INFO = N + 1 END IF GO TO 70 END IF * * Compute Eigenvectors * (Real Workspace: need 2*N) * (Complex Workspace: need 2*N) * IF( ILV ) THEN IF( ILVL ) THEN IF( ILVR ) THEN CHTEMP = 'B' ELSE CHTEMP = 'L' END IF ELSE CHTEMP = 'R' END IF * CALL ZTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL, $ VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ), $ IERR ) IF( IERR.NE.0 ) THEN INFO = N + 2 GO TO 70 END IF * * Undo balancing on VL and VR and normalization * (Workspace: none needed) * IF( ILVL ) THEN CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VL, LDVL, IERR ) DO 30 JC = 1, N TEMP = ZERO DO 10 JR = 1, N TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) ) 10 CONTINUE IF( TEMP.LT.SMLNUM ) $ GO TO 30 TEMP = ONE / TEMP DO 20 JR = 1, N VL( JR, JC ) = VL( JR, JC )*TEMP 20 CONTINUE 30 CONTINUE END IF IF( ILVR ) THEN CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ), $ RWORK( IRIGHT ), N, VR, LDVR, IERR ) DO 60 JC = 1, N TEMP = ZERO DO 40 JR = 1, N TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) ) 40 CONTINUE IF( TEMP.LT.SMLNUM ) $ GO TO 60 TEMP = ONE / TEMP DO 50 JR = 1, N VR( JR, JC ) = VR( JR, JC )*TEMP 50 CONTINUE 60 CONTINUE END IF END IF * * Undo scaling if necessary * IF( ILASCL ) $ CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR ) * IF( ILBSCL ) $ CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR ) * 70 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of ZGGEV * END SUBROUTINE DLABAD( SMALL, LARGE ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL * .. * * Purpose * ======= * * DLABAD takes as input the values computed by DLAMCH for underflow and * overflow, and returns the square root of each of these values if the * log of LARGE is sufficiently large. This subroutine is intended to * identify machines with a large exponent range, such as the Crays, and * redefine the underflow and overflow limits to be the square roots of * the values computed by DLAMCH. This subroutine is needed because * DLAMCH does not compensate for poor arithmetic in the upper half of * the exponent range, as is found on a Cray. * * Arguments * ========= * * SMALL (input/output) DOUBLE PRECISION * On entry, the underflow threshold as computed by DLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of SMALL, otherwise unchanged. * * LARGE (input/output) DOUBLE PRECISION * On entry, the overflow threshold as computed by DLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of LARGE, otherwise unchanged. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LOG10, SQRT * .. * .. Executable Statements .. * * If it looks like we're on a Cray, take the square root of * SMALL and LARGE to avoid overflow and underflow problems. * IF( LOG10( LARGE ).GT.2000.D0 ) THEN SMALL = SQRT( SMALL ) LARGE = SQRT( LARGE ) END IF * RETURN * * End of DLABAD * END DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANGE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * complex matrix A. * * Description * =========== * * ZLANGE returns the value * * ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANGE as described * above. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. When M = 0, * ZLANGE is set to zero. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. When N = 0, * ZLANGE is set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, M SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, M WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, M VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANGE = VALUE RETURN * * End of ZLANGE * END SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, LDA, LDB, N * .. * .. Array Arguments .. DOUBLE PRECISION LSCALE( * ), RSCALE( * ), WORK( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZGGBAL balances a pair of general complex matrices (A,B). This * involves, first, permuting A and B by similarity transformations to * isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N * elements on the diagonal; and second, applying a diagonal similarity * transformation to rows and columns ILO to IHI to make the rows * and columns as close in norm as possible. Both steps are optional. * * Balancing may reduce the 1-norm of the matrices, and improve the * accuracy of the computed eigenvalues and/or eigenvectors in the * generalized eigenvalue problem A*x = lambda*B*x. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the operations to be performed on A and B: * = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 * and RSCALE(I) = 1.0 for i=1,...,N; * = 'P': permute only; * = 'S': scale only; * = 'B': both permute and scale. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the input matrix A. * On exit, A is overwritten by the balanced matrix. * If JOB = 'N', A is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) COMPLEX*16 array, dimension (LDB,N) * On entry, the input matrix B. * On exit, B is overwritten by the balanced matrix. * If JOB = 'N', B is not referenced. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * ILO (output) INTEGER * IHI (output) INTEGER * ILO and IHI are set to integers such that on exit * A(i,j) = 0 and B(i,j) = 0 if i > j and * j = 1,...,ILO-1 or i = IHI+1,...,N. * If JOB = 'N' or 'S', ILO = 1 and IHI = N. * * LSCALE (output) DOUBLE PRECISION array, dimension (N) * Details of the permutations and scaling factors applied * to the left side of A and B. If P(j) is the index of the * row interchanged with row j, and D(j) is the scaling factor * applied to row j, then * LSCALE(j) = P(j) for J = 1,...,ILO-1 * = D(j) for J = ILO,...,IHI * = P(j) for J = IHI+1,...,N. * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * * RSCALE (output) DOUBLE PRECISION array, dimension (N) * Details of the permutations and scaling factors applied * to the right side of A and B. If P(j) is the index of the * column interchanged with column j, and D(j) is the scaling * factor applied to column j, then * RSCALE(j) = P(j) for J = 1,...,ILO-1 * = D(j) for J = ILO,...,IHI * = P(j) for J = IHI+1,...,N. * The order in which the interchanges are made is N to IHI+1, * then 1 to ILO-1. * * WORK (workspace) DOUBLE PRECISION array, dimension (6*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * See R.C. WARD, Balancing the generalized eigenvalue problem, * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) DOUBLE PRECISION THREE, SCLFAC PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1, $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN, $ M, NR, NRP2 DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, $ SFMIN, SUM, T, TA, TB, TC COMPLEX*16 CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IZAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DSCAL, XERBLA, ZDSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGBAL', -INFO ) RETURN END IF * K = 1 L = N * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( LSAME( JOB, 'N' ) ) THEN ILO = 1 IHI = N DO 10 I = 1, N LSCALE( I ) = ONE RSCALE( I ) = ONE 10 CONTINUE RETURN END IF * IF( K.EQ.L ) THEN ILO = 1 IHI = 1 LSCALE( 1 ) = ONE RSCALE( 1 ) = ONE RETURN END IF * IF( LSAME( JOB, 'S' ) ) $ GO TO 190 * GO TO 30 * * Permute the matrices A and B to isolate the eigenvalues. * * Find row with one nonzero in columns 1 through L * 20 CONTINUE L = LM1 IF( L.NE.1 ) $ GO TO 30 * RSCALE( 1 ) = 1 LSCALE( 1 ) = 1 GO TO 190 * 30 CONTINUE LM1 = L - 1 DO 80 I = L, 1, -1 DO 40 J = 1, LM1 JP1 = J + 1 IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 50 40 CONTINUE J = L GO TO 70 * 50 CONTINUE DO 60 J = JP1, L IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 80 60 CONTINUE J = JP1 - 1 * 70 CONTINUE M = L IFLOW = 1 GO TO 160 80 CONTINUE GO TO 100 * * Find column with one nonzero in rows K through N * 90 CONTINUE K = K + 1 * 100 CONTINUE DO 150 J = K, L DO 110 I = K, LM1 IP1 = I + 1 IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 120 110 CONTINUE I = L GO TO 140 120 CONTINUE DO 130 I = IP1, L IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO ) $ GO TO 150 130 CONTINUE I = IP1 - 1 140 CONTINUE M = K IFLOW = 2 GO TO 160 150 CONTINUE GO TO 190 * * Permute rows M and I * 160 CONTINUE LSCALE( M ) = I IF( I.EQ.M ) $ GO TO 170 CALL ZSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA ) CALL ZSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB ) * * Permute columns M and J * 170 CONTINUE RSCALE( M ) = J IF( J.EQ.M ) $ GO TO 180 CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 ) CALL ZSWAP( L, B( 1, J ), 1, B( 1, M ), 1 ) * 180 CONTINUE GO TO ( 20, 90 )IFLOW * 190 CONTINUE ILO = K IHI = L * IF( ILO.EQ.IHI ) $ RETURN * IF( LSAME( JOB, 'P' ) ) $ RETURN * * Balance the submatrix in rows ILO to IHI. * NR = IHI - ILO + 1 DO 200 I = ILO, IHI RSCALE( I ) = ZERO LSCALE( I ) = ZERO * WORK( I ) = ZERO WORK( I+N ) = ZERO WORK( I+2*N ) = ZERO WORK( I+3*N ) = ZERO WORK( I+4*N ) = ZERO WORK( I+5*N ) = ZERO 200 CONTINUE * * Compute right side vector in resulting linear equations * BASL = LOG10( SCLFAC ) DO 240 I = ILO, IHI DO 230 J = ILO, IHI IF( A( I, J ).EQ.CZERO ) THEN TA = ZERO GO TO 210 END IF TA = LOG10( CABS1( A( I, J ) ) ) / BASL * 210 CONTINUE IF( B( I, J ).EQ.CZERO ) THEN TB = ZERO GO TO 220 END IF TB = LOG10( CABS1( B( I, J ) ) ) / BASL * 220 CONTINUE WORK( I+4*N ) = WORK( I+4*N ) - TA - TB WORK( J+5*N ) = WORK( J+5*N ) - TA - TB 230 CONTINUE 240 CONTINUE * COEF = ONE / DBLE( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO IT = 1 * * Start generalized conjugate gradient iteration * 250 CONTINUE * GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) + $ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 ) * EW = ZERO EWC = ZERO DO 260 I = ILO, IHI EW = EW + WORK( I+4*N ) EWC = EWC + WORK( I+5*N ) 260 CONTINUE * GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 350 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC-THREE*EW ) TC = COEF5*( EW-THREE*EWC ) * CALL DSCAL( NR, BETA, WORK( ILO ), 1 ) CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 ) * CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 ) CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 ) * DO 270 I = ILO, IHI WORK( I ) = WORK( I ) + TC WORK( I+N ) = WORK( I+N ) + T 270 CONTINUE * * Apply matrix to vector * DO 300 I = ILO, IHI KOUNT = 0 SUM = ZERO DO 290 J = ILO, IHI IF( A( I, J ).EQ.CZERO ) $ GO TO 280 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 280 CONTINUE IF( B( I, J ).EQ.CZERO ) $ GO TO 290 KOUNT = KOUNT + 1 SUM = SUM + WORK( J ) 290 CONTINUE WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM 300 CONTINUE * DO 330 J = ILO, IHI KOUNT = 0 SUM = ZERO DO 320 I = ILO, IHI IF( A( I, J ).EQ.CZERO ) $ GO TO 310 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 310 CONTINUE IF( B( I, J ).EQ.CZERO ) $ GO TO 320 KOUNT = KOUNT + 1 SUM = SUM + WORK( I+N ) 320 CONTINUE WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM 330 CONTINUE * SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) + $ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 ) ALPHA = GAMMA / SUM * * Determine correction to current iteration * CMAX = ZERO DO 340 I = ILO, IHI COR = ALPHA*WORK( I+N ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE( I ) = LSCALE( I ) + COR COR = ALPHA*WORK( I ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE( I ) = RSCALE( I ) + COR 340 CONTINUE IF( CMAX.LT.HALF ) $ GO TO 350 * CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 ) CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 ) * PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 250 * * End generalized conjugate gradient iteration * 350 CONTINUE SFMIN = DLAMCH( 'S' ) SFMAX = ONE / SFMIN LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) DO 360 I = ILO, IHI IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA ) RAB = ABS( A( I, IRAB+ILO-1 ) ) IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDA ) RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE( I ) = SCLFAC**IR ICAB = IZAMAX( IHI, A( 1, I ), 1 ) CAB = ABS( A( ICAB, I ) ) ICAB = IZAMAX( IHI, B( 1, I ), 1 ) CAB = MAX( CAB, ABS( B( ICAB, I ) ) ) LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE ) JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) RSCALE( I ) = SCLFAC**JC 360 CONTINUE * * Row scaling of matrices A and B * DO 370 I = ILO, IHI CALL ZDSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA ) CALL ZDSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB ) 370 CONTINUE * * Column scaling of matrices A and B * DO 380 J = ILO, IHI CALL ZDSCAL( IHI, RSCALE( J ), A( 1, J ), 1 ) CALL ZDSCAL( IHI, RSCALE( J ), B( 1, J ), 1 ) 380 CONTINUE * RETURN * * End of ZGGBAL * END SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEQRF computes a QR factorization of a complex M-by-N matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(M,N)-by-N upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of min(m,n) elementary reflectors (see Further * Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * For optimum performance LWORK >= N*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) LWKOPT = N*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQRF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = N IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = N IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the QR factorization of the current block * A(i:m,i:i+ib-1) * CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.N ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB, $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(i:m,i+ib:n) from the left * CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward', $ 'Columnwise', M-I+1, N-I-IB+1, IB, $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), $ LDA, WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of ZGEQRF * END SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), Q( LDQ, * ), $ Z( LDZ, * ) * .. * * Purpose * ======= * * ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper * Hessenberg form using unitary transformations, where A is a * general matrix and B is upper triangular: Q' * A * Z = H and * Q' * B * Z = T, where H is upper Hessenberg, T is upper triangular, * and Q and Z are unitary, and ' means conjugate transpose. * * The unitary matrices Q and Z are determined as products of Givens * rotations. They may either be formed explicitly, or they may be * postmultiplied into input matrices Q1 and Z1, so that * * Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' * Q1 * B * Z1' = (Q1*Q) * T * (Z1*Z)' * * Arguments * ========= * * COMPQ (input) CHARACTER*1 * = 'N': do not compute Q; * = 'I': Q is initialized to the unit matrix, and the * unitary matrix Q is returned; * = 'V': Q must contain a unitary matrix Q1 on entry, * and the product Q1*Q is returned. * * COMPZ (input) CHARACTER*1 * = 'N': do not compute Q; * = 'I': Q is initialized to the unit matrix, and the * unitary matrix Q is returned; * = 'V': Q must contain a unitary matrix Q1 on entry, * and the product Q1*Q is returned. * * N (input) INTEGER * The order of the matrices A and B. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that A is already upper triangular in rows and * columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally set * by a previous call to ZGGBAL; otherwise they should be set * to 1 and N respectively. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) * On entry, the N-by-N general matrix to be reduced. * On exit, the upper triangle and the first subdiagonal of A * are overwritten with the upper Hessenberg matrix H, and the * rest is set to zero. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) COMPLEX*16 array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. * On exit, the upper triangular matrix T = Q' B Z. The * elements below the diagonal are set to zero. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * Q (input/output) COMPLEX*16 array, dimension (LDQ, N) * If COMPQ='N': Q is not referenced. * If COMPQ='I': on entry, Q need not be set, and on exit it * contains the unitary matrix Q, where Q' * is the product of the Givens transformations * which are applied to A and B on the left. * If COMPQ='V': on entry, Q must contain a unitary matrix * Q1, and on exit this is overwritten by Q1*Q. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. * * Z (input/output) COMPLEX*16 array, dimension (LDZ, N) * If COMPZ='N': Z is not referenced. * If COMPZ='I': on entry, Z need not be set, and on exit it * contains the unitary matrix Z, which is * the product of the Givens transformations * which are applied to A and B on the right. * If COMPZ='V': on entry, Z must contain a unitary matrix * Z1, and on exit this is overwritten by Z1*Z. * * LDZ (input) INTEGER * The leading dimension of the array Z. * LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * This routine reduces A to Hessenberg and B to triangular form by * an unblocked reduction, as described in _Matrix_Computations_, * by Golub and van Loan (Johns Hopkins Press). * * ===================================================================== * * .. Parameters .. COMPLEX*16 CONE, CZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL ILQ, ILZ INTEGER ICOMPQ, ICOMPZ, JCOL, JROW DOUBLE PRECISION C COMPLEX*16 CTEMP, S * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Decode COMPQ * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * * Decode COMPZ * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Test the input parameters. * INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -11 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGHRD', -INFO ) RETURN END IF * * Initialize Q and Z if desired. * IF( ICOMPQ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Zero out lower triangle of B * DO 20 JCOL = 1, N - 1 DO 10 JROW = JCOL + 1, N B( JROW, JCOL ) = CZERO 10 CONTINUE 20 CONTINUE * * Reduce A and B * DO 40 JCOL = ILO, IHI - 2 * DO 30 JROW = IHI, JCOL + 2, -1 * * Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) * CTEMP = A( JROW-1, JCOL ) CALL ZLARTG( CTEMP, A( JROW, JCOL ), C, S, $ A( JROW-1, JCOL ) ) A( JROW, JCOL ) = CZERO CALL ZROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, $ A( JROW, JCOL+1 ), LDA, C, S ) CALL ZROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB, $ B( JROW, JROW-1 ), LDB, C, S ) IF( ILQ ) $ CALL ZROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, $ DCONJG( S ) ) * * Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) * CTEMP = B( JROW, JROW ) CALL ZLARTG( CTEMP, B( JROW, JROW-1 ), C, S, $ B( JROW, JROW ) ) B( JROW, JROW-1 ) = CZERO CALL ZROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S ) CALL ZROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C, $ S ) IF( ILZ ) $ CALL ZROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S ) 30 CONTINUE 40 CONTINUE * RETURN * * End of ZGGHRD * END SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ) COMPLEX*16 A( LDA, * ), ALPHA( * ), B( LDB, * ), $ BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * ZHGEQZ implements a single-shift version of the QZ * method for finding the generalized eigenvalues w(i)=ALPHA(i)/BETA(i) * of the equation * * det( A - w(i) B ) = 0 * * If JOB='S', then the pair (A,B) is simultaneously * reduced to Schur form (i.e., A and B are both upper triangular) by * applying one unitary tranformation (usually called Q) on the left and * another (usually called Z) on the right. The diagonal elements of * A are then ALPHA(1),...,ALPHA(N), and of B are BETA(1),...,BETA(N). * * If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the unitary * transformations used to reduce (A,B) are accumulated into the arrays * Q and Z s.t.: * * Q(in) A(in) Z(in)* = Q(out) A(out) Z(out)* * Q(in) B(in) Z(in)* = Q(out) B(out) Z(out)* * * Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix * Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), * pp. 241--256. * * Arguments * ========= * * JOB (input) CHARACTER*1 * = 'E': compute only ALPHA and BETA. A and B will not * necessarily be put into generalized Schur form. * = 'S': put A and B into generalized Schur form, as well * as computing ALPHA and BETA. * * COMPQ (input) CHARACTER*1 * = 'N': do not modify Q. * = 'V': multiply the array Q on the right by the conjugate * transpose of the unitary tranformation that is * applied to the left side of A and B to reduce them * to Schur form. * = 'I': like COMPQ='V', except that Q will be initialized to * the identity first. * * COMPZ (input) CHARACTER*1 * = 'N': do not modify Z. * = 'V': multiply the array Z on the right by the unitary * tranformation that is applied to the right side of * A and B to reduce them to Schur form. * = 'I': like COMPZ='V', except that Z will be initialized to * the identity first. * * N (input) INTEGER * The order of the matrices A, B, Q, and Z. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that A is already upper triangular in rows and * columns 1:ILO-1 and IHI+1:N. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * A (input/output) COMPLEX*16 array, dimension (LDA, N) * On entry, the N-by-N upper Hessenberg matrix A. Elements * below the subdiagonal must be zero. * If JOB='S', then on exit A and B will have been * simultaneously reduced to upper triangular form. * If JOB='E', then on exit A will have been destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max( 1, N ). * * B (input/output) COMPLEX*16 array, dimension (LDB, N) * On entry, the N-by-N upper triangular matrix B. Elements * below the diagonal must be zero. * If JOB='S', then on exit A and B will have been * simultaneously reduced to upper triangular form. * If JOB='E', then on exit B will have been destroyed. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max( 1, N ). * * ALPHA (output) COMPLEX*16 array, dimension (N) * The diagonal elements of A when the pair (A,B) has been * reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N * are the generalized eigenvalues. * * BETA (output) COMPLEX*16 array, dimension (N) * The diagonal elements of B when the pair (A,B) has been * reduced to Schur form. ALPHA(i)/BETA(i) i=1,...,N * are the generalized eigenvalues. A and B are normalized * so that BETA(1),...,BETA(N) are non-negative real numbers. * * Q (input/output) COMPLEX*16 array, dimension (LDQ, N) * If COMPQ='N', then Q will not be referenced. * If COMPQ='V' or 'I', then the conjugate transpose of the * unitary transformations which are applied to A and B on * the left will be applied to the array Q on the right. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= 1. * If COMPQ='V' or 'I', then LDQ >= N. * * Z (input/output) COMPLEX*16 array, dimension (LDZ, N) * If COMPZ='N', then Z will not be referenced. * If COMPZ='V' or 'I', then the unitary transformations which * are applied to A and B on the right will be applied to the * array Z on the right. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1. * If COMPZ='V' or 'I', then LDZ >= N. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,N). * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1,...,N: the QZ iteration did not converge. (A,B) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO+1,...,N should be correct. * = N+1,...,2*N: the shift calculation failed. (A,B) is not * in Schur form, but ALPHA(i) and BETA(i), * i=INFO-N+1,...,N should be correct. * > 2*N: various "impossible" errors. * * Further Details * =============== * * We assume that complex ABS works as long as its value is less than * overflow. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D+0 ) * .. * .. Local Scalars .. LOGICAL ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, $ JR, MAXIT DOUBLE PRECISION ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL, $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T, $ U12, X * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANHS EXTERNAL LSAME, DLAMCH, ZLANHS * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN, $ SQRT * .. * .. Statement Functions .. DOUBLE PRECISION ABS1 * .. * .. Statement Function definitions .. ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) * .. * .. Executable Statements .. * * Decode JOB, COMPQ, COMPZ * IF( LSAME( JOB, 'E' ) ) THEN ILSCHR = .FALSE. ISCHUR = 1 ELSE IF( LSAME( JOB, 'S' ) ) THEN ILSCHR = .TRUE. ISCHUR = 2 ELSE ISCHUR = 0 END IF * IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'V' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF * IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF * * Check Argument Values * INFO = 0 WORK( 1 ) = MAX( 1, N ) LQUERY = ( LWORK.EQ.-1 ) IF( ISCHUR.EQ.0 ) THEN INFO = -1 ELSE IF( ICOMPQ.EQ.0 ) THEN INFO = -2 ELSE IF( ICOMPZ.EQ.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( ILO.LT.1 ) THEN INFO = -5 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ELSE IF( LDA.LT.N ) THEN INFO = -8 ELSE IF( LDB.LT.N ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN INFO = -14 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN INFO = -16 ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN INFO = -18 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZHGEQZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * * WORK( 1 ) = CMPLX( 1 ) IF( N.LE.0 ) THEN WORK( 1 ) = DCMPLX( 1 ) RETURN END IF * * Initialize Q and Z * IF( ICOMPQ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ ) * * Machine Constants * IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'S' ) ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) ANORM = ZLANHS( 'F', IN, A( ILO, ILO ), LDA, RWORK ) BNORM = ZLANHS( 'F', IN, B( ILO, ILO ), LDB, RWORK ) ATOL = MAX( SAFMIN, ULP*ANORM ) BTOL = MAX( SAFMIN, ULP*BNORM ) ASCALE = ONE / MAX( SAFMIN, ANORM ) BSCALE = ONE / MAX( SAFMIN, BNORM ) * * * Set Eigenvalues IHI+1:N * DO 10 J = IHI + 1, N ABSB = ABS( B( J, J ) ) IF( ABSB.GT.SAFMIN ) THEN SIGNBC = DCONJG( B( J, J ) / ABSB ) B( J, J ) = ABSB IF( ILSCHR ) THEN CALL ZSCAL( J-1, SIGNBC, B( 1, J ), 1 ) CALL ZSCAL( J, SIGNBC, A( 1, J ), 1 ) ELSE A( J, J ) = A( J, J )*SIGNBC END IF IF( ILZ ) $ CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 ) ELSE B( J, J ) = CZERO END IF ALPHA( J ) = A( J, J ) BETA( J ) = B( J, J ) 10 CONTINUE * * If IHI < ILO, skip QZ steps * IF( IHI.LT.ILO ) $ GO TO 190 * * MAIN QZ ITERATION LOOP * * Initialize dynamic indices * * Eigenvalues ILAST+1:N have been found. * Column operations modify rows IFRSTM:whatever * Row operations modify columns whatever:ILASTM * * If only eigenvalues are being computed, then * IFRSTM is the row of the last splitting row above row ILAST; * this is always at least ILO. * IITER counts iterations since the last eigenvalue was found, * to tell when to use an extraordinary shift. * MAXIT is the maximum number of QZ sweeps allowed. * ILAST = IHI IF( ILSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 ESHIFT = CZERO MAXIT = 30*( IHI-ILO+1 ) * DO 170 JITER = 1, MAXIT * * Check for too many iterations. * IF( JITER.GT.MAXIT ) $ GO TO 180 * * Split the matrix if possible. * * Two tests: * 1: A(j,j-1)=0 or j=ILO * 2: B(j,j)=0 * * Special case: j=ILAST * IF( ILAST.EQ.ILO ) THEN GO TO 60 ELSE IF( ABS1( A( ILAST, ILAST-1 ) ).LE.ATOL ) THEN A( ILAST, ILAST-1 ) = CZERO GO TO 60 END IF END IF * IF( ABS( B( ILAST, ILAST ) ).LE.BTOL ) THEN B( ILAST, ILAST ) = CZERO GO TO 50 END IF * * General case: j= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The upper triangular matrix A. * * LDA (input) INTEGER * The leading dimension of array A. LDA >= max(1,N). * * B (input) COMPLEX*16 array, dimension (LDB,N) * The upper triangular matrix B. B must have real diagonal * elements. * * LDB (input) INTEGER * The leading dimension of array B. LDB >= max(1,N). * * VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the unitary matrix Q * of left Schur vectors returned by ZHGEQZ). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of (A,B); * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of (A,B) specified by * SELECT, stored consecutively in the columns of * VL, in the same order as their eigenvalues. * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER * The leading dimension of array VL. * LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must * contain an N-by-N matrix Q (usually the unitary matrix Z * of right Schur vectors returned by ZHGEQZ). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of (A,B); * if HOWMNY = 'B', the matrix Z*X; * if HOWMNY = 'S', the right eigenvectors of (A,B) specified by * SELECT, stored consecutively in the columns of * VR, in the same order as their eigenvalues. * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER * The leading dimension of the array VR. * LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) INTEGER * The number of columns in the arrays VL and/or VR actually * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M * is set to N. Each selected eigenvector occupies one column. * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP, $ LSA, LSB INTEGER I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC, $ J, JE, JR DOUBLE PRECISION ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG, $ BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA, $ SCALE, SMALL, TEMP, ULP, XMAX COMPLEX*16 BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH COMPLEX*16 ZLADIV EXTERNAL LSAME, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZGEMV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION ABS1 * .. * .. Statement Function definitions .. ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) ) * .. * .. Executable Statements .. * * Decode and Test the input parameters * IF( LSAME( HOWMNY, 'A' ) ) THEN IHWMNY = 1 ILALL = .TRUE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN IHWMNY = 2 ILALL = .FALSE. ILBACK = .FALSE. ELSE IF( LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'T' ) ) THEN IHWMNY = 3 ILALL = .TRUE. ILBACK = .TRUE. ELSE IHWMNY = -1 END IF * IF( LSAME( SIDE, 'R' ) ) THEN ISIDE = 1 COMPL = .FALSE. COMPR = .TRUE. ELSE IF( LSAME( SIDE, 'L' ) ) THEN ISIDE = 2 COMPL = .TRUE. COMPR = .FALSE. ELSE IF( LSAME( SIDE, 'B' ) ) THEN ISIDE = 3 COMPL = .TRUE. COMPR = .TRUE. ELSE ISIDE = -1 END IF * INFO = 0 IF( ISIDE.LT.0 ) THEN INFO = -1 ELSE IF( IHWMNY.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGEVC', -INFO ) RETURN END IF * * Count the number of eigenvectors * IF( .NOT.ILALL ) THEN IM = 0 DO 10 J = 1, N IF( SELECT( J ) ) $ IM = IM + 1 10 CONTINUE ELSE IM = N END IF * * Check diagonal of B * ILBBAD = .FALSE. DO 20 J = 1, N IF( DIMAG( B( J, J ) ).NE.ZERO ) $ ILBBAD = .TRUE. 20 CONTINUE * IF( ILBBAD ) THEN INFO = -7 ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN INFO = -10 ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN INFO = -12 ELSE IF( MM.LT.IM ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTGEVC', -INFO ) RETURN END IF * * Quick return if possible * M = IM IF( N.EQ.0 ) $ RETURN * * Machine Constants * SAFMIN = DLAMCH( 'Safe minimum' ) BIG = ONE / SAFMIN CALL DLABAD( SAFMIN, BIG ) ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) SMALL = SAFMIN*N / ULP BIG = ONE / SMALL BIGNUM = ONE / ( SAFMIN*N ) * * Compute the 1-norm of each column of the strictly upper triangular * part of A and B to check for possible overflow in the triangular * solver. * ANORM = ABS1( A( 1, 1 ) ) BNORM = ABS1( B( 1, 1 ) ) RWORK( 1 ) = ZERO RWORK( N+1 ) = ZERO DO 40 J = 2, N RWORK( J ) = ZERO RWORK( N+J ) = ZERO DO 30 I = 1, J - 1 RWORK( J ) = RWORK( J ) + ABS1( A( I, J ) ) RWORK( N+J ) = RWORK( N+J ) + ABS1( B( I, J ) ) 30 CONTINUE ANORM = MAX( ANORM, RWORK( J )+ABS1( A( J, J ) ) ) BNORM = MAX( BNORM, RWORK( N+J )+ABS1( B( J, J ) ) ) 40 CONTINUE * ASCALE = ONE / MAX( ANORM, SAFMIN ) BSCALE = ONE / MAX( BNORM, SAFMIN ) * * Left eigenvectors * IF( COMPL ) THEN IEIG = 0 * * Main loop over eigenvalues * DO 140 JE = 1, N IF( ILALL ) THEN ILCOMP = .TRUE. ELSE ILCOMP = SELECT( JE ) END IF IF( ILCOMP ) THEN IEIG = IEIG + 1 * IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. $ ABS( DBLE( B( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * DO 50 JR = 1, N VL( JR, IEIG ) = CZERO 50 CONTINUE VL( IEIG, IEIG ) = CONE GO TO 140 END IF * * Non-singular eigenvalue: * Compute coefficients a and b in * H * y ( a A - b B ) = 0 * TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, $ ABS( DBLE( B( JE, JE ) ) )*BSCALE, SAFMIN ) SALPHA = ( TEMP*A( JE, JE ) )*ASCALE SBETA = ( TEMP*DBLE( B( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * * Scale to avoid underflow * LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. $ SMALL * SCALE = ONE IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), $ ABS1( BCOEFF ) ) ) ) IF( LSA ) THEN ACOEFF = ASCALE*( SCALE*SBETA ) ELSE ACOEFF = SCALE*ACOEFF END IF IF( LSB ) THEN BCOEFF = BSCALE*( SCALE*SALPHA ) ELSE BCOEFF = SCALE*BCOEFF END IF END IF * ACOEFA = ABS( ACOEFF ) BCOEFA = ABS1( BCOEFF ) XMAX = ONE DO 60 JR = 1, N WORK( JR ) = CZERO 60 CONTINUE WORK( JE ) = CONE DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * H * Triangular solve of (a A - b B) y = 0 * * H * (rowwise in (a A - b B) , or columnwise in a A - b B) * DO 100 J = JE + 1, N * * Compute * j-1 * SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) * k=je * (Scale if necessary) * TEMP = ONE / XMAX IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM* $ TEMP ) THEN DO 70 JR = JE, J - 1 WORK( JR ) = TEMP*WORK( JR ) 70 CONTINUE XMAX = ONE END IF SUMA = CZERO SUMB = CZERO * DO 80 JR = JE, J - 1 SUMA = SUMA + DCONJG( A( JR, J ) )*WORK( JR ) SUMB = SUMB + DCONJG( B( JR, J ) )*WORK( JR ) 80 CONTINUE SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB * * Form x(j) = - SUM / conjg( a*A(j,j) - b*B(j,j) ) * * with scaling and perturbation of the denominator * D = DCONJG( ACOEFF*A( J, J )-BCOEFF*B( J, J ) ) IF( ABS1( D ).LE.DMIN ) $ D = DCMPLX( DMIN ) * IF( ABS1( D ).LT.ONE ) THEN IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN TEMP = ONE / ABS1( SUM ) DO 90 JR = JE, J - 1 WORK( JR ) = TEMP*WORK( JR ) 90 CONTINUE XMAX = TEMP*XMAX SUM = TEMP*SUM END IF END IF WORK( J ) = ZLADIV( -SUM, D ) XMAX = MAX( XMAX, ABS1( WORK( J ) ) ) 100 CONTINUE * * Back transform eigenvector if HOWMNY='B'. * IF( ILBACK ) THEN CALL ZGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ), LDVL, $ WORK( JE ), 1, CZERO, WORK( N+1 ), 1 ) ISRC = 2 IBEG = 1 ELSE ISRC = 1 IBEG = JE END IF * * Copy and scale eigenvector into column of VL * XMAX = ZERO DO 110 JR = IBEG, N XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) 110 CONTINUE * IF( XMAX.GT.SAFMIN ) THEN TEMP = ONE / XMAX DO 120 JR = IBEG, N VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) 120 CONTINUE ELSE IBEG = N + 1 END IF * DO 130 JR = 1, IBEG - 1 VL( JR, IEIG ) = CZERO 130 CONTINUE * END IF 140 CONTINUE END IF * * Right eigenvectors * IF( COMPR ) THEN IEIG = IM + 1 * * Main loop over eigenvalues * DO 250 JE = N, 1, -1 IF( ILALL ) THEN ILCOMP = .TRUE. ELSE ILCOMP = SELECT( JE ) END IF IF( ILCOMP ) THEN IEIG = IEIG - 1 * IF( ABS1( A( JE, JE ) ).LE.SAFMIN .AND. $ ABS( DBLE( B( JE, JE ) ) ).LE.SAFMIN ) THEN * * Singular matrix pencil -- return unit eigenvector * DO 150 JR = 1, N VR( JR, IEIG ) = CZERO 150 CONTINUE VR( IEIG, IEIG ) = CONE GO TO 250 END IF * * Non-singular eigenvalue: * Compute coefficients a and b in * * ( a A - b B ) x = 0 * TEMP = ONE / MAX( ABS1( A( JE, JE ) )*ASCALE, $ ABS( DBLE( B( JE, JE ) ) )*BSCALE, SAFMIN ) SALPHA = ( TEMP*A( JE, JE ) )*ASCALE SBETA = ( TEMP*DBLE( B( JE, JE ) ) )*BSCALE ACOEFF = SBETA*ASCALE BCOEFF = SALPHA*BSCALE * * Scale to avoid underflow * LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT. $ SMALL * SCALE = ONE IF( LSA ) $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG ) IF( LSB ) $ SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )* $ MIN( BNORM, BIG ) ) IF( LSA .OR. LSB ) THEN SCALE = MIN( SCALE, ONE / $ ( SAFMIN*MAX( ONE, ABS( ACOEFF ), $ ABS1( BCOEFF ) ) ) ) IF( LSA ) THEN ACOEFF = ASCALE*( SCALE*SBETA ) ELSE ACOEFF = SCALE*ACOEFF END IF IF( LSB ) THEN BCOEFF = BSCALE*( SCALE*SALPHA ) ELSE BCOEFF = SCALE*BCOEFF END IF END IF * ACOEFA = ABS( ACOEFF ) BCOEFA = ABS1( BCOEFF ) XMAX = ONE DO 160 JR = 1, N WORK( JR ) = CZERO 160 CONTINUE WORK( JE ) = CONE DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN ) * * Triangular solve of (a A - b B) x = 0 (columnwise) * * WORK(1:j-1) contains sums w, * WORK(j+1:JE) contains x * DO 170 JR = 1, JE - 1 WORK( JR ) = ACOEFF*A( JR, JE ) - BCOEFF*B( JR, JE ) 170 CONTINUE WORK( JE ) = CONE * DO 210 J = JE - 1, 1, -1 * * Form x(j) := - w(j) / d * with scaling and perturbation of the denominator * D = ACOEFF*A( J, J ) - BCOEFF*B( J, J ) IF( ABS1( D ).LE.DMIN ) $ D = DCMPLX( DMIN ) * IF( ABS1( D ).LT.ONE ) THEN IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN TEMP = ONE / ABS1( WORK( J ) ) DO 180 JR = 1, JE WORK( JR ) = TEMP*WORK( JR ) 180 CONTINUE END IF END IF * WORK( J ) = ZLADIV( -WORK( J ), D ) * IF( J.GT.1 ) THEN * * w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling * IF( ABS1( WORK( J ) ).GT.ONE ) THEN TEMP = ONE / ABS1( WORK( J ) ) IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE. $ BIGNUM*TEMP ) THEN DO 190 JR = 1, JE WORK( JR ) = TEMP*WORK( JR ) 190 CONTINUE END IF END IF * CA = ACOEFF*WORK( J ) CB = BCOEFF*WORK( J ) DO 200 JR = 1, J - 1 WORK( JR ) = WORK( JR ) + CA*A( JR, J ) - $ CB*B( JR, J ) 200 CONTINUE END IF 210 CONTINUE * * Back transform eigenvector if HOWMNY='B'. * IF( ILBACK ) THEN CALL ZGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1, $ CZERO, WORK( N+1 ), 1 ) ISRC = 2 IEND = N ELSE ISRC = 1 IEND = JE END IF * * Copy and scale eigenvector into column of VR * XMAX = ZERO DO 220 JR = 1, IEND XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) ) 220 CONTINUE * IF( XMAX.GT.SAFMIN ) THEN TEMP = ONE / XMAX DO 230 JR = 1, IEND VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR ) 230 CONTINUE ELSE IEND = 0 END IF * DO 240 JR = IEND + 1, N VR( JR, IEIG ) = CZERO 240 CONTINUE * END IF 250 CONTINUE END IF * RETURN * * End of ZTGEVC * END SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER JOB, SIDE INTEGER IHI, ILO, INFO, LDV, M, N * .. * .. Array Arguments .. DOUBLE PRECISION LSCALE( * ), RSCALE( * ) COMPLEX*16 V( LDV, * ) * .. * * Purpose * ======= * * ZGGBAK forms the right or left eigenvectors of a complex generalized * eigenvalue problem A*x = lambda*B*x, by backward transformation on * the computed eigenvectors of the balanced pair of matrices output by * ZGGBAL. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies the type of backward transformation required: * = 'N': do nothing, return immediately; * = 'P': do backward transformation for permutation only; * = 'S': do backward transformation for scaling only; * = 'B': do backward transformations for both permutation and * scaling. * JOB must be the same as the argument JOB supplied to ZGGBAL. * * SIDE (input) CHARACTER*1 * = 'R': V contains right eigenvectors; * = 'L': V contains left eigenvectors. * * N (input) INTEGER * The number of rows of the matrix V. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * The integers ILO and IHI determined by ZGGBAL. * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. * * LSCALE (input) DOUBLE PRECISION array, dimension (N) * Details of the permutations and/or scaling factors applied * to the left side of A and B, as returned by ZGGBAL. * * RSCALE (input) DOUBLE PRECISION array, dimension (N) * Details of the permutations and/or scaling factors applied * to the right side of A and B, as returned by ZGGBAL. * * M (input) INTEGER * The number of columns of the matrix V. M >= 0. * * V (input/output) COMPLEX*16 array, dimension (LDV,M) * On entry, the matrix of right or left eigenvectors to be * transformed, as returned by ZTGEVC. * On exit, V is overwritten by the transformed eigenvectors. * * LDV (input) INTEGER * The leading dimension of the matrix V. LDV >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * See R.C. Ward, Balancing the generalized eigenvalue problem, * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFTV, RIGHTV INTEGER I, K * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters * RIGHTV = LSAME( SIDE, 'R' ) LEFTV = LSAME( SIDE, 'L' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( ILO.LT.1 ) THEN INFO = -4 ELSE IF( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGGBAK', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( M.EQ.0 ) $ RETURN IF( LSAME( JOB, 'N' ) ) $ RETURN * IF( ILO.EQ.IHI ) $ GO TO 30 * * Backward balance * IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward transformation on right eigenvectors * IF( RIGHTV ) THEN DO 10 I = ILO, IHI CALL ZDSCAL( M, RSCALE( I ), V( I, 1 ), LDV ) 10 CONTINUE END IF * * Backward transformation on left eigenvectors * IF( LEFTV ) THEN DO 20 I = ILO, IHI CALL ZDSCAL( M, LSCALE( I ), V( I, 1 ), LDV ) 20 CONTINUE END IF END IF * * Backward permutation * 30 CONTINUE IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN * * Backward permutation on right eigenvectors * IF( RIGHTV ) THEN IF( ILO.EQ.1 ) $ GO TO 50 DO 40 I = ILO - 1, 1, -1 K = RSCALE( I ) IF( K.EQ.I ) $ GO TO 40 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 40 CONTINUE * 50 CONTINUE IF( IHI.EQ.N ) $ GO TO 70 DO 60 I = IHI + 1, N K = RSCALE( I ) IF( K.EQ.I ) $ GO TO 60 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 60 CONTINUE END IF * * Backward permutation on left eigenvectors * 70 CONTINUE IF( LEFTV ) THEN IF( ILO.EQ.1 ) $ GO TO 90 DO 80 I = ILO - 1, 1, -1 K = LSCALE( I ) IF( K.EQ.I ) $ GO TO 80 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 80 CONTINUE * 90 CONTINUE IF( IHI.EQ.N ) $ GO TO 110 DO 100 I = IHI + 1, N K = LSCALE( I ) IF( K.EQ.I ) $ GO TO 100 CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV ) 100 CONTINUE END IF END IF * 110 CONTINUE * RETURN * * End of ZGGBAK * END SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEQR2 computes a QR factorization of a complex m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i)' to A(i:m,i+1:n) from the left * ALPHA = A( I, I ) A( I, I ) = ONE CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = ALPHA END IF 10 CONTINUE RETURN * * End of ZGEQR2 * END SUBROUTINE ZLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. DOUBLE PRECISION CS COMPLEX*16 F, G, R, SN * .. * * Purpose * ======= * * ZLARTG generates a plane rotation so that * * [ CS SN ] [ F ] [ R ] * [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. * [ -SN CS ] [ G ] [ 0 ] * * This is a faster version of the BLAS1 routine ZROTG, except for * the following differences: * F and G are unchanged on return. * If G=0, then CS=1 and SN=0. * If F=0, then CS=0 and SN is chosen so that R is real. * * Arguments * ========= * * F (input) COMPLEX*16 * The first component of vector to be rotated. * * G (input) COMPLEX*16 * The second component of vector to be rotated. * * CS (output) DOUBLE PRECISION * The cosine of the rotation. * * SN (output) COMPLEX*16 * The sine of the rotation. * * R (output) COMPLEX*16 * The nonzero component of the rotated vector. * * Further Details * ======= ======= * * 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION TWO, ONE, ZERO PARAMETER ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN, $ SAFMN2, SAFMX2, SCALE COMPLEX*16 FF, FS, GS * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, $ MAX, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION ABS1, ABSSQ * .. * .. Save statement .. SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Statement Function definitions .. ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 END IF SCALE = MAX( ABS1( F ), ABS1( G ) ) FS = F GS = G COUNT = 0 IF( SCALE.GE.SAFMX2 ) THEN 10 CONTINUE COUNT = COUNT + 1 FS = FS*SAFMN2 GS = GS*SAFMN2 SCALE = SCALE*SAFMN2 IF( SCALE.GE.SAFMX2 ) $ GO TO 10 ELSE IF( SCALE.LE.SAFMN2 ) THEN IF( G.EQ.CZERO ) THEN CS = ONE SN = CZERO R = F RETURN END IF 20 CONTINUE COUNT = COUNT - 1 FS = FS*SAFMX2 GS = GS*SAFMX2 SCALE = SCALE*SAFMX2 IF( SCALE.LE.SAFMN2 ) $ GO TO 20 END IF F2 = ABSSQ( FS ) G2 = ABSSQ( GS ) IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN * * This is a rare case: F is very small. * IF( F.EQ.CZERO ) THEN CS = ZERO R = DLAPY2( DBLE( G ), DIMAG( G ) ) * Do complex/real division explicitly with two real divisions D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) RETURN END IF F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) * G2 and G2S are accurate * G2 is at least SAFMIN, and G2S is at least SAFMN2 G2S = SQRT( G2 ) * Error in CS from underflow in F2S is at most * UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS * If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, * and so CS .lt. sqrt(SAFMIN) * If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN * and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) * Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S CS = F2S / G2S * Make sure abs(FF) = 1 * Do complex/real division explicitly with 2 real divisions IF( ABS1( F ).GT.ONE ) THEN D = DLAPY2( DBLE( F ), DIMAG( F ) ) FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) ELSE DR = SAFMX2*DBLE( F ) DI = SAFMX2*DIMAG( F ) D = DLAPY2( DR, DI ) FF = DCMPLX( DR / D, DI / D ) END IF SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) R = CS*F + SN*G ELSE * * This is the most common case. * Neither F2 nor F2/G2 are less than SAFMIN * F2S cannot overflow, and it is accurate * F2S = SQRT( ONE+G2 / F2 ) * Do the F2S(real)*FS(complex) multiply with two real multiplies R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) CS = ONE / F2S D = F2 + G2 * Do complex/real division explicitly with two real divisions SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) SN = SN*DCONJG( GS ) IF( COUNT.NE.0 ) THEN IF( COUNT.GT.0 ) THEN DO 30 I = 1, COUNT R = R*SAFMX2 30 CONTINUE ELSE DO 40 I = 1, -COUNT R = R*SAFMN2 40 CONTINUE END IF END IF END IF RETURN * * End of ZLARTG * END DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANHS returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * Hessenberg matrix A. * * Description * =========== * * ZLANHS returns the value * * ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANHS as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, ZLANHS is * set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The n by n upper Hessenberg matrix A; the part of A below the * first sub-diagonal is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANHS = VALUE RETURN * * End of ZLANHS * END SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, INCY, N DOUBLE PRECISION C COMPLEX*16 S * .. * .. Array Arguments .. COMPLEX*16 CX( * ), CY( * ) * .. * * Purpose * ======= * * ZROT applies a plane rotation, where the cos (C) is real and the * sin (S) is complex, and the vectors CX and CY are complex. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vectors CX and CY. * * CX (input/output) COMPLEX*16 array, dimension (N) * On input, the vector X. * On output, CX is overwritten with C*X + S*Y. * * INCX (input) INTEGER * The increment between successive values of CY. INCX <> 0. * * CY (input/output) COMPLEX*16 array, dimension (N) * On input, the vector Y. * On output, CY is overwritten with -CONJG(S)*X + C*Y. * * INCY (input) INTEGER * The increment between successive values of CY. INCX <> 0. * * C (input) DOUBLE PRECISION * S (input) COMPLEX*16 * C and S define a rotation * [ C S ] * [ -conjg(S) C ] * where C*C + S*CONJG(S) = 1.0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IX, IY COMPLEX*16 STEMP * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 .AND. INCY.EQ.1 ) $ GO TO 20 * * Code for unequal increments or equal increments not equal to 1 * IX = 1 IY = 1 IF( INCX.LT.0 ) $ IX = ( -N+1 )*INCX + 1 IF( INCY.LT.0 ) $ IY = ( -N+1 )*INCY + 1 DO 10 I = 1, N STEMP = C*CX( IX ) + S*CY( IY ) CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX ) CX( IX ) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * * Code for both increments equal to 1 * 20 CONTINUE DO 30 I = 1, N STEMP = C*CX( I ) + S*CY( I ) CY( I ) = C*CY( I ) - DCONJG( S )*CX( I ) CX( I ) = STEMP 30 CONTINUE RETURN END SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZGETRF computes an LU factorization of a general M-by-N matrix A * using partial pivoting with row interchanges. * * The factorization has the form * A = P * L * U * where P is a permutation matrix, L is lower triangular with unit * diagonal elements (lower trapezoidal if m > n), and U is upper * triangular (upper trapezoidal if m < n). * * This is the right-looking Level 3 BLAS version of the algorithm. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix to be factored. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * IPIV (output) INTEGER array, dimension (min(M,N)) * The pivot indices; for 1 <= i <= min(M,N), row i of the * matrix was interchanged with row IPIV(i). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, IINFO, J, JB, NB * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGETRF', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Determine the block size for this environment. * NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN * * Use unblocked code. * CALL ZGETF2( M, N, A, LDA, IPIV, INFO ) ELSE * * Use blocked code. * DO 20 J = 1, MIN( M, N ), NB JB = MIN( MIN( M, N )-J+1, NB ) * * Factor diagonal and subdiagonal blocks and test for exact * singularity. * CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) * * Adjust INFO and the pivot indices. * IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO + J - 1 DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE * * Apply interchanges to columns 1:J-1. * CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) * IF( J+JB.LE.N ) THEN * * Apply interchanges to columns J+JB:N. * CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) * * Compute block row of U. * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), $ LDA ) IF( J+JB.LE.M ) THEN * * Update trailing submatrix. * CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), $ LDA ) END IF END IF 20 CONTINUE END IF RETURN * * End of ZGETRF * END SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZGETRS solves a system of linear equations * A * X = B, A**T * X = B, or A**H * X = B * with a general N-by-N matrix A using the LU factorization computed * by ZGETRF. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A**T * X = B (Transpose) * = 'C': A**H * X = B (Conjugate transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The factors L and U from the factorization A = P*L*U * as computed by ZGETRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (input) INTEGER array, dimension (N) * The pivot indices from ZGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL NOTRAN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLASWP, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGETRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A * X = B. * * Apply row interchanges to the right hand sides. * CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) * * Solve L*X = B, overwriting B with X. * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve U*X = B, overwriting B with X. * CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) ELSE * * Solve A**T * X = B or A**H * X = B. * * Solve U'*X = B, overwriting B with X. * CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, $ A, LDA, B, LDB ) * * Solve L'*X = B, overwriting B with X. * CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, $ LDA, B, LDB ) * * Apply row interchanges to the solution vectors. * CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) END IF * RETURN * * End of ZGETRS * END SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZGETF2 computes an LU factorization of a general m-by-n matrix A * using partial pivoting with row interchanges. * * The factorization has the form * A = P * L * U * where P is a permutation matrix, L is lower triangular with unit * diagonal elements (lower trapezoidal if m > n), and U is upper * triangular (upper trapezoidal if m < n). * * This is the right-looking Level 2 BLAS version of the algorithm. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix to be factored. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * IPIV (output) INTEGER array, dimension (min(M,N)) * The pivot indices; for 1 <= i <= min(M,N), row i of the * matrix was interchanged with row IPIV(i). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, U(k,k) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, and division by zero will occur if it is used * to solve a system of equations. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER J, JP * .. * .. External Functions .. INTEGER IZAMAX EXTERNAL IZAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGETF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * DO 10 J = 1, MIN( M, N ) * * Find pivot and test for singularity. * JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 ) IPIV( J ) = JP IF( A( JP, J ).NE.ZERO ) THEN * * Apply the interchange to columns 1:N. * IF( JP.NE.J ) $ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) * * Compute elements J+1:M of J-th column. * IF( J.LT.M ) $ CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) * ELSE IF( INFO.EQ.0 ) THEN * INFO = J END IF * IF( J.LT.MIN( M, N ) ) THEN * * Update trailing submatrix. * CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), $ LDA, A( J+1, J+1 ), LDA ) END IF 10 CONTINUE RETURN * * End of ZGETF2 * END SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASWP performs a series of row interchanges on the matrix A. * One row interchange is initiated for each of rows K1 through K2 of A. * * Arguments * ========= * * N (input) INTEGER * The number of columns of the matrix A. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the matrix of column dimension N to which the row * interchanges will be applied. * On exit, the permuted matrix. * * LDA (input) INTEGER * The leading dimension of the array A. * * K1 (input) INTEGER * The first element of IPIV for which a row interchange will * be done. * * K2 (input) INTEGER * The last element of IPIV for which a row interchange will * be done. * * IPIV (input) INTEGER array, dimension (M*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. * * INCX (input) INTEGER * The increment between successive values of IPIV. If IPIV * is negative, the pivots are applied in reverse order. * * Further Details * =============== * * Modified by * R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA * * ===================================================================== * * .. Local Scalars .. INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 COMPLEX*16 TEMP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.GT.0 ) THEN IX0 = K1 I1 = K1 I2 = K2 INC = 1 ELSE IF( INCX.LT.0 ) THEN IX0 = 1 + ( 1-K2 )*INCX I1 = K2 I2 = K1 INC = -1 ELSE RETURN END IF * N32 = ( N / 32 )*32 IF( N32.NE.0 ) THEN DO 30 J = 1, N32, 32 IX = IX0 DO 20 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 10 K = J, J + 31 TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 10 CONTINUE END IF IX = IX + INCX 20 CONTINUE 30 CONTINUE END IF IF( N32.NE.N ) THEN N32 = N32 + 1 IX = IX0 DO 50 I = I1, I2, INC IP = IPIV( IX ) IF( IP.NE.I ) THEN DO 40 K = N32, N TEMP = A( I, K ) A( I, K ) = A( IP, K ) A( IP, K ) = TEMP 40 CONTINUE END IF IX = IX + INCX 50 CONTINUE END IF * RETURN * * End of ZLASWP * END SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1999 * * .. Scalar Arguments .. CHARACTER JOBU, JOBVT INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION RWORK( * ), S( * ) COMPLEX*16 A( LDA, * ), U( LDU, * ), VT( LDVT, * ), $ WORK( * ) * .. * * Purpose * ======= * * ZGESVD computes the singular value decomposition (SVD) of a complex * M-by-N matrix A, optionally computing the left and/or right singular * vectors. The SVD is written * * A = U * SIGMA * conjugate-transpose(V) * * where SIGMA is an M-by-N matrix which is zero except for its * min(m,n) diagonal elements, U is an M-by-M unitary matrix, and * V is an N-by-N unitary matrix. The diagonal elements of SIGMA * are the singular values of A; they are real and non-negative, and * are returned in descending order. The first min(m,n) columns of * U and V are the left and right singular vectors of A. * * Note that the routine returns V**H, not V. * * Arguments * ========= * * JOBU (input) CHARACTER*1 * Specifies options for computing all or part of the matrix U: * = 'A': all M columns of U are returned in array U: * = 'S': the first min(m,n) columns of U (the left singular * vectors) are returned in the array U; * = 'O': the first min(m,n) columns of U (the left singular * vectors) are overwritten on the array A; * = 'N': no columns of U (no left singular vectors) are * computed. * * JOBVT (input) CHARACTER*1 * Specifies options for computing all or part of the matrix * V**H: * = 'A': all N rows of V**H are returned in the array VT; * = 'S': the first min(m,n) rows of V**H (the right singular * vectors) are returned in the array VT; * = 'O': the first min(m,n) rows of V**H (the right singular * vectors) are overwritten on the array A; * = 'N': no rows of V**H (no right singular vectors) are * computed. * * JOBVT and JOBU cannot both be 'O'. * * M (input) INTEGER * The number of rows of the input matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the input matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, * if JOBU = 'O', A is overwritten with the first min(m,n) * columns of U (the left singular vectors, * stored columnwise); * if JOBVT = 'O', A is overwritten with the first min(m,n) * rows of V**H (the right singular vectors, * stored rowwise); * if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A * are destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * S (output) DOUBLE PRECISION array, dimension (min(M,N)) * The singular values of A, sorted so that S(i) >= S(i+1). * * U (output) COMPLEX*16 array, dimension (LDU,UCOL) * (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. * If JOBU = 'A', U contains the M-by-M unitary matrix U; * if JOBU = 'S', U contains the first min(m,n) columns of U * (the left singular vectors, stored columnwise); * if JOBU = 'N' or 'O', U is not referenced. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= 1; if * JOBU = 'S' or 'A', LDU >= M. * * VT (output) COMPLEX*16 array, dimension (LDVT,N) * If JOBVT = 'A', VT contains the N-by-N unitary matrix * V**H; * if JOBVT = 'S', VT contains the first min(m,n) rows of * V**H (the right singular vectors, stored rowwise); * if JOBVT = 'N' or 'O', VT is not referenced. * * LDVT (input) INTEGER * The leading dimension of the array VT. LDVT >= 1; if * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= 1. * LWORK >= 2*MIN(M,N)+MAX(M,N). * For good performance, LWORK should generally be larger. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)) * On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the * unconverged superdiagonal elements of an upper bidiagonal * matrix B whose diagonal is in S (not necessarily sorted). * B satisfies A = U * B * VT, so it has the same singular * values as A, and singular vectors related by U and VT. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * > 0: if ZBDSQR did not converge, INFO specifies how many * superdiagonals of an intermediate bidiagonal form B * did not converge to zero. See the description of RWORK * above for details. * * ===================================================================== * * .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS, $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS INTEGER BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL, $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU, $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU, $ NRVT, WRKBL DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) COMPLEX*16 CDUM( 1 ) * .. * .. External Subroutines .. EXTERNAL DLASCL, XERBLA, ZBDSQR, ZGEBRD, ZGELQF, ZGEMM, $ ZGEQRF, ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNGLQ, $ ZUNGQR, ZUNMBR * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL LSAME, ILAENV, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 MINMN = MIN( M, N ) MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 ) WNTUA = LSAME( JOBU, 'A' ) WNTUS = LSAME( JOBU, 'S' ) WNTUAS = WNTUA .OR. WNTUS WNTUO = LSAME( JOBU, 'O' ) WNTUN = LSAME( JOBU, 'N' ) WNTVA = LSAME( JOBVT, 'A' ) WNTVS = LSAME( JOBVT, 'S' ) WNTVAS = WNTVA .OR. WNTVS WNTVO = LSAME( JOBVT, 'O' ) WNTVN = LSAME( JOBVT, 'N' ) MINWRK = 1 LQUERY = ( LWORK.EQ.-1 ) * IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN INFO = -1 ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR. $ ( WNTVO .AND. WNTUO ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN INFO = -9 ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR. $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN INFO = -11 END IF * * Compute workspace * (Note: Comments in the code beginning "Workspace:" describe the * minimal amount of workspace needed at that point in the code, * as well as the preferred amount for good performance. * CWorkspace refers to complex workspace, and RWorkspace to * real workspace. NB refers to the optimal block size for the * immediately following subroutine, as returned by ILAENV.) * IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) .AND. M.GT.0 .AND. $ N.GT.0 ) THEN IF( M.GE.N ) THEN * * Space needed for ZBDSQR is BDSPAC = 5*N * IF( M.GE.MNTHR ) THEN IF( WNTUN ) THEN * * Path 1 (M much larger than N, JOBU='N') * MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, $ -1 ) MAXWRK = MAX( MAXWRK, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) IF( WNTVO .OR. WNTVAS ) $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MINWRK = 3*N MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') * WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, $ N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or * 'A') * WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, $ N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = MAX( N*N+WRKBL, N*N+M*N ) MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') * WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, $ N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') * WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, $ N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = 2*N*N + WRKBL MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUS .AND. WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' or * 'A') * WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M, $ N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') * WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, $ M, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') * WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, $ M, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = 2*N*N + WRKBL MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTUA .AND. WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' or * 'A') * WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M, $ M, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+2*N* $ ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) ) WRKBL = MAX( WRKBL, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MAXWRK = N*N + WRKBL MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) END IF ELSE * * Path 10 (M at least N, but not much larger) * MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, $ -1, -1 ) IF( WNTUS .OR. WNTUO ) $ MAXWRK = MAX( MAXWRK, 2*N+N* $ ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) ) IF( WNTUA ) $ MAXWRK = MAX( MAXWRK, 2*N+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) ) IF( .NOT.WNTVN ) $ MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) ) MINWRK = 2*N + M MAXWRK = MAX( MINWRK, MAXWRK ) END IF ELSE * * Space needed for ZBDSQR is BDSPAC = 5*M * IF( N.GE.MNTHR ) THEN IF( WNTVN ) THEN * * Path 1t(N much larger than M, JOBVT='N') * MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, $ -1 ) MAXWRK = MAX( MAXWRK, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) IF( WNTUO .OR. WNTUAS ) $ MAXWRK = MAX( MAXWRK, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MINWRK = 3*M MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') * WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, $ N, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', * JOBVT='O') * WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, $ N, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = MAX( M*M+WRKBL, M*M+M*N ) MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') * WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, $ N, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') * WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, $ N, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = 2*M*M + WRKBL MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVS .AND. WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', * JOBVT='S') * WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M, $ N, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') * WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, $ N, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') * WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, $ N, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = 2*M*M + WRKBL MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) ELSE IF( WNTVA .AND. WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', * JOBVT='A') * WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N, $ N, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+2*M* $ ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) ) WRKBL = MAX( WRKBL, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) ) WRKBL = MAX( WRKBL, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MAXWRK = M*M + WRKBL MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) END IF ELSE * * Path 10t(N greater than M, but not much larger) * MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N, $ -1, -1 ) IF( WNTVS .OR. WNTVO ) $ MAXWRK = MAX( MAXWRK, 2*M+M* $ ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) ) IF( WNTVA ) $ MAXWRK = MAX( MAXWRK, 2*M+N* $ ILAENV( 1, 'ZUNGBR', 'P', N, N, M, -1 ) ) IF( .NOT.WNTUN ) $ MAXWRK = MAX( MAXWRK, 2*M+( M-1 )* $ ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) ) MINWRK = 2*M + N MAXWRK = MAX( MINWRK, MAXWRK ) END IF END IF WORK( 1 ) = MAXWRK END IF * IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGESVD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN IF( LWORK.GE.1 ) $ WORK( 1 ) = ONE RETURN END IF * * Get machine constants * EPS = DLAMCH( 'P' ) SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = ZLANGE( 'M', M, N, A, LDA, DUM ) ISCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ISCL = 1 CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR ) ELSE IF( ANRM.GT.BIGNUM ) THEN ISCL = 1 CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR ) END IF * IF( M.GE.N ) THEN * * A has at least as many rows as columns. If A has sufficiently * more rows than columns, first reduce using the QR * decomposition (if sufficient workspace available) * IF( M.GE.MNTHR ) THEN * IF( WNTUN ) THEN * * Path 1 (M much larger than N, JOBU='N') * No left singular vectors to be computed * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: need 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Zero out below R * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ), $ LDA ) IE = 1 ITAUQ = 1 ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) NCVT = 0 IF( WNTVO .OR. WNTVAS ) THEN * * If right singular vectors desired, generate P'. * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) NCVT = N END IF IRWORK = IE + N * * Perform bidiagonal QR iteration, computing right * singular vectors of A in A if desired * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA, $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO ) * * If right singular vectors desired in VT, copy them there * IF( WNTVAS ) $ CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT ) * ELSE IF( WNTUO .AND. WNTVN ) THEN * * Path 2 (M much larger than N, JOBU='O', JOBVT='N') * N left singular vectors to be overwritten on A and * no right singular vectors to be computed * IF( LWORK.GE.N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN * * WORK(IU) is LDA by N, WORK(IR) is N by N * LDWRKU = LDA LDWRKR = N ELSE * * WORK(IU) is LDWRKU by N, WORK(IR) is N by N * LDWRKU = ( LWORK-N*N ) / N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IR) and zero out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: need 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1, $ WORK( IR ), LDWRKR, CDUM, 1, $ RWORK( IRWORK ), INFO ) IU = ITAUQ * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A * (CWorkspace: need N*N+N, prefer N*N+M*N) * (RWorkspace: 0) * DO 10 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ), $ LDA, WORK( IR ), LDWRKR, CZERO, $ WORK( IU ), LDWRKU ) CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, $ A( I, 1 ), LDA ) 10 CONTINUE * ELSE * * Insufficient workspace for a fast algorithm * IE = 1 ITAUQ = 1 ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize A * (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) * (RWorkspace: N) * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing A * (CWorkspace: need 3*N, prefer 2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A * (CWorkspace: need 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1, $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUO .AND. WNTVAS ) THEN * * Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') * N left singular vectors to be overwritten on A and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA LDWRKR = N ELSE * * WORK(IU) is LDWRKU by N and WORK(IR) is N by N * LDWRKU = ( LWORK-N*N ) / N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ), $ LDVT ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT, copying result to WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR ) * * Generate left vectors bidiagonalizing R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT * (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) and computing right * singular vectors of R in VT * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, $ LDVT, WORK( IR ), LDWRKR, CDUM, 1, $ RWORK( IRWORK ), INFO ) IU = ITAUQ * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in WORK(IU) and copying to A * (CWorkspace: need N*N+N, prefer N*N+M*N) * (RWorkspace: 0) * DO 20 I = 1, M, LDWRKU CHUNK = MIN( M-I+1, LDWRKU ) CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ), $ LDA, WORK( IR ), LDWRKR, CZERO, $ WORK( IU ), LDWRKU ) CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU, $ A( I, 1 ), LDA ) 20 CONTINUE * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, VT( 2, 1 ), $ LDVT ) * * Generate Q in A * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: N) * CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in A by left vectors bidiagonalizing R * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in VT * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTUS ) THEN * IF( WNTVN ) THEN * * Path 4 (M much larger than N, JOBU='S', JOBVT='N') * N left singular vectors to be computed in U and * no right singular vectors to be computed * IF( LWORK.GE.N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IR) is LDA by N * LDWRKR = LDA ELSE * * WORK(IR) is N by N * LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IR), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), $ LDWRKR ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, $ 1, WORK( IR ), LDWRKR, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IR), storing result in U * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, $ WORK( IR ), LDWRKR, CZERO, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Zero out below R in A * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ A( 2, 1 ), LDA ) * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTVO ) THEN * * Path 5 (M much larger than N, JOBU='S', JOBVT='O') * N left singular vectors to be computed in U and * N right singular vectors to be overwritten on A * IF( LWORK.GE.2*N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = N ELSE * * WORK(IU) is N by N and WORK(IR) is N by N * LDWRKU = N IR = IU + LDWRKU*N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) * (CWorkspace: need 2*N*N+3*N, * prefer 2*N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, $ WORK( IR ), LDWRKR ) * * Generate left bidiagonalizing vectors in WORK(IU) * (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (CWorkspace: need 2*N*N+3*N-1, * prefer 2*N*N+2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) * (CWorkspace: need 2*N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), $ LDWRKU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in U * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, $ WORK( IU ), LDWRKU, CZERO, U, LDU ) * * Copy right singular vectors of R to A * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Zero out below R in A * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ A( 2, 1 ), LDA ) * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left vectors bidiagonalizing R * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing R in A * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A, $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTVAS ) THEN * * Path 6 (M much larger than N, JOBU='S', JOBVT='S' * or 'A') * N left singular vectors to be computed in U and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+3*N ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is N by N * LDWRKU = N END IF ITAU = IU + LDWRKU*N IWORK = ITAU + N * * Compute A=Q*R * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IU+1 ), LDWRKU ) * * Generate Q in A * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to VT * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, $ LDVT ) * * Generate left bidiagonalizing vectors in WORK(IU) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (CWorkspace: need N*N+3*N-1, * prefer N*N+2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply Q in A by left singular vectors of R in * WORK(IU), storing result in U * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA, $ WORK( IU ), LDWRKU, CZERO, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in VT * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * END IF * ELSE IF( WNTUA ) THEN * IF( WNTVN ) THEN * * Path 7 (M much larger than N, JOBU='A', JOBVT='N') * M left singular vectors to be computed in U and * no right singular vectors to be computed * IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IR) is LDA by N * LDWRKR = LDA ELSE * * WORK(IR) is N by N * LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Copy R to WORK(IR), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), $ LDWRKR ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IR+1 ), LDWRKR ) * * Generate Q in U * (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IR) * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, $ 1, WORK( IR ), LDWRKR, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IR), storing result in A * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, $ WORK( IR ), LDWRKR, CZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need N+M, prefer N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Zero out below R in A * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ A( 2, 1 ), LDA ) * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in A * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, $ 1, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTVO ) THEN * * Path 8 (M much larger than N, JOBU='A', JOBVT='O') * M left singular vectors to be computed in U and * N right singular vectors to be overwritten on A * IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN * * WORK(IU) is LDA by N and WORK(IR) is N by N * LDWRKU = LDA IR = IU + LDWRKU*N LDWRKR = N ELSE * * WORK(IU) is N by N and WORK(IR) is N by N * LDWRKU = N IR = IU + LDWRKU*N LDWRKR = N END IF ITAU = IR + LDWRKR*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IU+1 ), LDWRKU ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to * WORK(IR) * (CWorkspace: need 2*N*N+3*N, * prefer 2*N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, $ WORK( IR ), LDWRKR ) * * Generate left bidiagonalizing vectors in WORK(IU) * (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (CWorkspace: need 2*N*N+3*N-1, * prefer 2*N*N+2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in WORK(IR) * (CWorkspace: need 2*N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, WORK( IU ), $ LDWRKU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, $ WORK( IU ), LDWRKU, CZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) * * Copy right singular vectors of R from WORK(IR) to A * CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need N+M, prefer N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Zero out below R in A * CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ A( 2, 1 ), LDA ) * * Bidiagonalize R in A * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in A * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in A * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A, $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) * END IF * ELSE IF( WNTVAS ) THEN * * Path 9 (M much larger than N, JOBU='A', JOBVT='S' * or 'A') * M left singular vectors to be computed in U and * N right singular vectors to be computed in VT * IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*N ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is N by N * LDWRKU = N END IF ITAU = IU + LDWRKU*N IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R to WORK(IU), zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ WORK( IU+1 ), LDWRKU ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in WORK(IU), copying result to VT * (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT, $ LDVT ) * * Generate left bidiagonalizing vectors in WORK(IU) * (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (CWorkspace: need N*N+3*N-1, * prefer N*N+2*N+(N-1)*NB) * (RWorkspace: need 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of R in WORK(IU) and computing * right singular vectors of R in VT * (CWorkspace: need N*N) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT, $ LDVT, WORK( IU ), LDWRKU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply Q in U by left singular vectors of R in * WORK(IU), storing result in A * (CWorkspace: need N*N) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU, $ WORK( IU ), LDWRKU, CZERO, A, LDA ) * * Copy left singular vectors of A from A to U * CALL ZLACPY( 'F', M, N, A, LDA, U, LDU ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + N * * Compute A=Q*R, copying result to U * (CWorkspace: need 2*N, prefer N+N*NB) * (RWorkspace: 0) * CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) * * Generate Q in U * (CWorkspace: need N+M, prefer N+M*NB) * (RWorkspace: 0) * CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy R from A to VT, zeroing out below it * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, $ VT( 2, 1 ), LDVT ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize R in VT * (CWorkspace: need 3*N, prefer 2*N+2*N*NB) * (RWorkspace: need N) * CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply Q in U by left bidiagonalizing vectors * in VT * (CWorkspace: need 2*N+M, prefer 2*N+M*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT, $ WORK( ITAUQ ), U, LDU, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in VT * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + N * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * END IF * END IF * ELSE * * M .LT. MNTHR * * Path 10 (M at least N, but not much larger) * Reduce to bidiagonal form without QR decomposition * IE = 1 ITAUQ = 1 ITAUP = ITAUQ + N IWORK = ITAUP + N * * Bidiagonalize A * (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) * (RWorkspace: need N) * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUAS ) THEN * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U * (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB) * (RWorkspace: 0) * CALL ZLACPY( 'L', M, N, A, LDA, U, LDU ) IF( WNTUS ) $ NCU = N IF( WNTUA ) $ NCU = M CALL ZUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVAS ) THEN * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT ) CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTUO ) THEN * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A * (CWorkspace: need 3*N, prefer 2*N+N*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVO ) THEN * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A * (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IRWORK = IE + N IF( WNTUAS .OR. WNTUO ) $ NRU = M IF( WNTUN ) $ NRU = 0 IF( WNTVAS .OR. WNTVO ) $ NCVT = N IF( WNTVN ) $ NCVT = 0 IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A, $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) ELSE * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in A and computing right singular * vectors in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), $ INFO ) END IF * END IF * ELSE * * A has more columns than rows. If A has sufficiently more * columns than rows, first reduce using the LQ decomposition (if * sufficient workspace available) * IF( N.GE.MNTHR ) THEN * IF( WNTVN ) THEN * * Path 1t(N much larger than M, JOBVT='N') * No right singular vectors to be computed * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Zero out above L * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ), $ LDA ) IE = 1 ITAUQ = 1 ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUO .OR. WNTUAS ) THEN * * If left singular vectors desired, generate Q * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IRWORK = IE + M NRU = 0 IF( WNTUO .OR. WNTUAS ) $ NRU = M * * Perform bidiagonal QR iteration, computing left singular * vectors of A in A if desired * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1, $ A, LDA, CDUM, 1, RWORK( IRWORK ), INFO ) * * If left singular vectors desired in U, copy them there * IF( WNTUAS ) $ CALL ZLACPY( 'F', M, M, A, LDA, U, LDU ) * ELSE IF( WNTVO .AND. WNTUN ) THEN * * Path 2t(N much larger than M, JOBU='N', JOBVT='O') * M right singular vectors to be overwritten on A and * no left singular vectors to be computed * IF( LWORK.GE.M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * LDWRKU = LDA CHUNK = N LDWRKR = M ELSE * * WORK(IU) is M by CHUNK and WORK(IR) is M by M * LDWRKU = M CHUNK = ( LWORK-M*M ) / M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IR) and zero out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing L * (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) IU = ITAUQ * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A * (CWorkspace: need M*M+M, prefer M*M+M*N) * (RWorkspace: 0) * DO 30 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ), $ LDWRKR, A( 1, I ), LDA, CZERO, $ WORK( IU ), LDWRKU ) CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, $ A( 1, I ), LDA ) 30 CONTINUE * ELSE * * Insufficient workspace for a fast algorithm * IE = 1 ITAUQ = 1 ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize A * (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing A * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA, $ CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTVO .AND. WNTUAS ) THEN * * Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') * M right singular vectors to be overwritten on A and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is LDA by M * LDWRKU = LDA CHUNK = N LDWRKR = LDA ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN * * WORK(IU) is LDA by N and WORK(IR) is M by M * LDWRKU = LDA CHUNK = N LDWRKR = M ELSE * * WORK(IU) is M by CHUNK and WORK(IR) is M by M * LDWRKU = M CHUNK = ( LWORK-M*M ) / M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing about above it * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ), $ LDU ) * * Generate Q in A * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in U, copying result to WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR ) * * Generate right vectors bidiagonalizing L in WORK(IR) * (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U, and computing right * singular vectors of L in WORK(IR) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) IU = ITAUQ * * Multiply right singular vectors of L in WORK(IR) by Q * in A, storing result in WORK(IU) and copying to A * (CWorkspace: need M*M+M, prefer M*M+M*N)) * (RWorkspace: 0) * DO 40 I = 1, N, CHUNK BLK = MIN( N-I+1, CHUNK ) CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ), $ LDWRKR, A( 1, I ), LDA, CZERO, $ WORK( IU ), LDWRKU ) CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU, $ A( 1, I ), LDA ) 40 CONTINUE * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ), $ LDU ) * * Generate Q in A * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in U * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in A * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, $ WORK( ITAUP ), A, LDA, WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left vectors bidiagonalizing L in U * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA, $ U, LDU, CDUM, 1, RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTVS ) THEN * IF( WNTUN ) THEN * * Path 4t(N much larger than M, JOBU='N', JOBVT='S') * M right singular vectors to be computed in VT and * no left singular vectors to be computed * IF( LWORK.GE.M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IR) is LDA by M * LDWRKR = LDA ELSE * * WORK(IR) is M by M * LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IR), zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), $ LDWRKR ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in A * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right vectors bidiagonalizing L in * WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IR) by * Q in A, storing result in VT * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ), $ LDWRKR, A, LDA, CZERO, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy result to VT * CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Zero out above L in A * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ A( 1, 2 ), LDA ) * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT, $ LDVT, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUO ) THEN * * Path 5t(N much larger than M, JOBU='O', JOBVT='S') * M right singular vectors to be computed in VT and * M left singular vectors to be overwritten on A * IF( LWORK.GE.2*M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is LDA by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = M ELSE * * WORK(IU) is M by M and WORK(IR) is M by M * LDWRKU = M IR = IU + LDWRKU*M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out below it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) * (CWorkspace: need 2*M*M+3*M, * prefer 2*M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, $ WORK( IR ), LDWRKR ) * * Generate right bidiagonalizing vectors in WORK(IU) * (CWorkspace: need 2*M*M+3*M-1, * prefer 2*M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) * (CWorkspace: need 2*M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), $ LDWRKR, CDUM, 1, RWORK( IRWORK ), $ INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in A, storing result in VT * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), $ LDWRKU, A, LDA, CZERO, VT, LDVT ) * * Copy left singular vectors of L to A * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Zero out above L in A * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ A( 1, 2 ), LDA ) * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right vectors bidiagonalizing L by Q in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors of L in A * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUAS ) THEN * * Path 6t(N much larger than M, JOBU='S' or 'A', * JOBVT='S') * M right singular vectors to be computed in VT and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+3*M ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IU) is LDA by N * LDWRKU = LDA ELSE * * WORK(IU) is LDA by M * LDWRKU = M END IF ITAU = IU + LDWRKU*M IWORK = ITAU + M * * Compute A=L*Q * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IU+LDWRKU ), LDWRKU ) * * Generate Q in A * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, $ LDU ) * * Generate right bidiagonalizing vectors in WORK(IU) * (CWorkspace: need M*M+3*M-1, * prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in A, storing result in VT * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), $ LDWRKU, A, LDA, CZERO, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ U( 1, 2 ), LDU ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in U * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in U by Q * in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * END IF * ELSE IF( WNTVA ) THEN * IF( WNTUN ) THEN * * Path 7t(N much larger than M, JOBU='N', JOBVT='A') * N right singular vectors to be computed in VT and * no left singular vectors to be computed * IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN * * Sufficient workspace for a fast algorithm * IR = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IR) is LDA by M * LDWRKR = LDA ELSE * * WORK(IR) is M by M * LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Copy L to WORK(IR), zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), $ LDWRKR ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IR+LDWRKR ), LDWRKR ) * * Generate Q in VT * (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IR) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate right bidiagonalizing vectors in WORK(IR) * (CWorkspace: need M*M+3*M-1, * prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of L in WORK(IR) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ), $ WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IR) by * Q in VT, storing result in A * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ), $ LDWRKR, VT, LDVT, CZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need M+N, prefer M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Zero out above L in A * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ A( 1, 2 ), LDA ) * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in A by Q * in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT, $ LDVT, CDUM, 1, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUO ) THEN * * Path 8t(N much larger than M, JOBU='O', JOBVT='A') * N right singular vectors to be computed in VT and * M left singular vectors to be overwritten on A * IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+2*LDA*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is LDA by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = LDA ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN * * WORK(IU) is LDA by M and WORK(IR) is M by M * LDWRKU = LDA IR = IU + LDWRKU*M LDWRKR = M ELSE * * WORK(IU) is M by M and WORK(IR) is M by M * LDWRKU = M IR = IU + LDWRKU*M LDWRKR = M END IF ITAU = IR + LDWRKR*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IU+LDWRKU ), LDWRKU ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to * WORK(IR) * (CWorkspace: need 2*M*M+3*M, * prefer 2*M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, $ WORK( IR ), LDWRKR ) * * Generate right bidiagonalizing vectors in WORK(IU) * (CWorkspace: need 2*M*M+3*M-1, * prefer 2*M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in WORK(IR) * (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR, $ WORK( ITAUQ ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in WORK(IR) and computing * right singular vectors of L in WORK(IU) * (CWorkspace: need 2*M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IU ), LDWRKU, WORK( IR ), $ LDWRKR, CDUM, 1, RWORK( IRWORK ), $ INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in VT, storing result in A * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), $ LDWRKU, VT, LDVT, CZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) * * Copy left singular vectors of A from WORK(IR) to A * CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A, $ LDA ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need M+N, prefer M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Zero out above L in A * CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ A( 1, 2 ), LDA ) * * Bidiagonalize L in A * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in A by Q * in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in A * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in A and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * ELSE IF( WNTUAS ) THEN * * Path 9t(N much larger than M, JOBU='S' or 'A', * JOBVT='A') * N right singular vectors to be computed in VT and * M left singular vectors to be computed in U * IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN * * Sufficient workspace for a fast algorithm * IU = 1 IF( LWORK.GE.WRKBL+LDA*M ) THEN * * WORK(IU) is LDA by M * LDWRKU = LDA ELSE * * WORK(IU) is M by M * LDWRKU = M END IF ITAU = IU + LDWRKU*M IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to WORK(IU), zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ), $ LDWRKU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ WORK( IU+LDWRKU ), LDWRKU ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in WORK(IU), copying result to U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S, $ RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U, $ LDU ) * * Generate right bidiagonalizing vectors in WORK(IU) * (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU, $ WORK( ITAUP ), WORK( IWORK ), $ LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of L in U and computing right * singular vectors of L in WORK(IU) * (CWorkspace: need M*M) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ), $ WORK( IU ), LDWRKU, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * * Multiply right singular vectors of L in WORK(IU) by * Q in VT, storing result in A * (CWorkspace: need M*M) * (RWorkspace: 0) * CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ), $ LDWRKU, VT, LDVT, CZERO, A, LDA ) * * Copy right singular vectors of A from A to VT * CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT ) * ELSE * * Insufficient workspace for a fast algorithm * ITAU = 1 IWORK = ITAU + M * * Compute A=L*Q, copying result to VT * (CWorkspace: need 2*M, prefer M+M*NB) * (RWorkspace: 0) * CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) * * Generate Q in VT * (CWorkspace: need M+N, prefer M+N*NB) * (RWorkspace: 0) * CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Copy L to U, zeroing out above it * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, $ U( 1, 2 ), LDU ) IE = 1 ITAUQ = ITAU ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize L in U * (CWorkspace: need 3*M, prefer 2*M+2*M*NB) * (RWorkspace: need M) * CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ), $ WORK( ITAUQ ), WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Multiply right bidiagonalizing vectors in U by Q * in VT * (CWorkspace: need 2*M+N, prefer 2*M+N*NB) * (RWorkspace: 0) * CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU, $ WORK( ITAUP ), VT, LDVT, $ WORK( IWORK ), LWORK-IWORK+1, IERR ) * * Generate left bidiagonalizing vectors in U * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) IRWORK = IE + M * * Perform bidiagonal QR iteration, computing left * singular vectors of A in U and computing right * singular vectors of A in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, $ RWORK( IRWORK ), INFO ) * END IF * END IF * END IF * ELSE * * N .LT. MNTHR * * Path 10t(N greater than M, but not much larger) * Reduce to bidiagonal form without LQ decomposition * IE = 1 ITAUQ = 1 ITAUP = ITAUQ + M IWORK = ITAUP + M * * Bidiagonalize A * (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) * (RWorkspace: M) * CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ), $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, $ IERR ) IF( WNTUAS ) THEN * * If left singular vectors desired in U, copy result to U * and generate left bidiagonalizing vectors in U * (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZLACPY( 'L', M, M, A, LDA, U, LDU ) CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVAS ) THEN * * If right singular vectors desired in VT, copy result to * VT and generate right bidiagonalizing vectors in VT * (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB) * (RWorkspace: 0) * CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT ) IF( WNTVA ) $ NRVT = N IF( WNTVS ) $ NRVT = M CALL ZUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTUO ) THEN * * If left singular vectors desired in A, generate left * bidiagonalizing vectors in A * (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IF( WNTVO ) THEN * * If right singular vectors desired in A, generate right * bidiagonalizing vectors in A * (CWorkspace: need 3*M, prefer 2*M+M*NB) * (RWorkspace: 0) * CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), $ WORK( IWORK ), LWORK-IWORK+1, IERR ) END IF IRWORK = IE + M IF( WNTUAS .OR. WNTUO ) $ NRU = M IF( WNTUN ) $ NRU = 0 IF( WNTVAS .OR. WNTVO ) $ NCVT = N IF( WNTVN ) $ NCVT = 0 IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT, $ LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in U and computing right singular * vectors in A * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A, $ LDA, U, LDU, CDUM, 1, RWORK( IRWORK ), $ INFO ) ELSE * * Perform bidiagonal QR iteration, if desired, computing * left singular vectors in A and computing right singular * vectors in VT * (CWorkspace: 0) * (RWorkspace: need BDSPAC) * CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT, $ LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ), $ INFO ) END IF * END IF * END IF * * Undo scaling if necessary * IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, $ RWORK( IE ), MINMN, IERR ) IF( ANRM.LT.SMLNUM ) $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, $ IERR ) IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, $ RWORK( IE ), MINMN, IERR ) END IF * * Return optimal workspace in WORK(1) * WORK( 1 ) = MAXWRK * RETURN * * End of ZGESVD * END SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1999 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), RWORK( * ) COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * ) * .. * * Purpose * ======= * * ZBDSQR computes the singular value decomposition (SVD) of a real * N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' * denotes the transpose of P), where S is a diagonal matrix with * non-negative diagonal elements (the singular values of B), and Q * and P are orthogonal matrices. * * The routine computes S, and optionally computes U * Q, P' * VT, * or Q' * C, for given complex input matrices U, VT, and C. * * See "Computing Small Singular Values of Bidiagonal Matrices With * Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, * no. 5, pp. 873-912, Sept 1990) and * "Accurate singular values and differential qd algorithms," by * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics * Department, University of California at Berkeley, July 1992 * for a detailed description of the algorithm. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * = 'U': B is upper bidiagonal; * = 'L': B is lower bidiagonal. * * N (input) INTEGER * The order of the matrix B. N >= 0. * * NCVT (input) INTEGER * The number of columns of the matrix VT. NCVT >= 0. * * NRU (input) INTEGER * The number of rows of the matrix U. NRU >= 0. * * NCC (input) INTEGER * The number of columns of the matrix C. NCC >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the n diagonal elements of the bidiagonal matrix B. * On exit, if INFO=0, the singular values of B in decreasing * order. * * E (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the elements of E contain the * offdiagonal elements of of the bidiagonal matrix whose SVD * is desired. On normal exit (INFO = 0), E is destroyed. * If the algorithm does not converge (INFO > 0), D and E * will contain the diagonal and superdiagonal elements of a * bidiagonal matrix orthogonally equivalent to the one given * as input. E(N) is used for workspace. * * VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) * On entry, an N-by-NCVT matrix VT. * On exit, VT is overwritten by P' * VT. * VT is not referenced if NCVT = 0. * * LDVT (input) INTEGER * The leading dimension of the array VT. * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. * * U (input/output) COMPLEX*16 array, dimension (LDU, N) * On entry, an NRU-by-N matrix U. * On exit, U is overwritten by U * Q. * U is not referenced if NRU = 0. * * LDU (input) INTEGER * The leading dimension of the array U. LDU >= max(1,NRU). * * C (input/output) COMPLEX*16 array, dimension (LDC, NCC) * On entry, an N-by-NCC matrix C. * On exit, C is overwritten by Q' * C. * C is not referenced if NCC = 0. * * LDC (input) INTEGER * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * * RWORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: If INFO = -i, the i-th argument had an illegal value * > 0: the algorithm did not converge; D and E contain the * elements of a bidiagonal matrix which is orthogonally * similar to the input matrix B; if INFO = i, i * elements of E have not converged to zero. * * Internal Parameters * =================== * * TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) * TOLMUL controls the convergence criterion of the QR loop. * If it is positive, TOLMUL*EPS is the desired relative * precision in the computed singular values. * If it is negative, abs(TOLMUL*EPS*sigma_max) is the * desired absolute accuracy in the computed singular * values (corresponds to relative accuracy * abs(TOLMUL*EPS) in the largest singular value. * abs(TOLMUL) should be between 1 and 1/EPS, and preferably * between 10 (for fast convergence) and .1/EPS * (for there to be some accuracy in the results). * Default is to lose at either one eighth or 2 of the * available decimal digits in each computed singular value * (whichever is smaller). * * MAXITR INTEGER, default = 6 * MAXITR controls the maximum number of passes of the * algorithm through its inner loop. The algorithms stops * (and so fails to converge) if the number of passes * through the inner loop exceeds MAXITR*N**2. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION NEGONE PARAMETER ( NEGONE = -1.0D0 ) DOUBLE PRECISION HNDRTH PARAMETER ( HNDRTH = 0.01D0 ) DOUBLE PRECISION TEN PARAMETER ( TEN = 10.0D0 ) DOUBLE PRECISION HNDRD PARAMETER ( HNDRD = 100.0D0 ) DOUBLE PRECISION MEIGTH PARAMETER ( MEIGTH = -0.125D0 ) INTEGER MAXITR PARAMETER ( MAXITR = 6 ) * .. * .. Local Scalars .. LOGICAL LOWER, ROTATE INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1, $ NM12, NM13, OLDLL, OLDM DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, $ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, $ SN, THRESH, TOL, TOLMUL, UNFL * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. External Subroutines .. EXTERNAL DLARTG, DLAS2, DLASQ1, DLASV2, XERBLA, ZDROT, $ ZDSCAL, ZLASR, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 LOWER = LSAME( UPLO, 'L' ) IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NCVT.LT.0 ) THEN INFO = -3 ELSE IF( NRU.LT.0 ) THEN INFO = -4 ELSE IF( NCC.LT.0 ) THEN INFO = -5 ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN INFO = -9 ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN INFO = -11 ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN INFO = -13 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZBDSQR', -INFO ) RETURN END IF IF( N.EQ.0 ) $ RETURN IF( N.EQ.1 ) $ GO TO 160 * * ROTATE is true if any singular vectors desired, false otherwise * ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) * * If no singular vectors desired, use qd algorithm * IF( .NOT.ROTATE ) THEN CALL DLASQ1( N, D, E, RWORK, INFO ) RETURN END IF * NM1 = N - 1 NM12 = NM1 + NM1 NM13 = NM12 + NM1 IDIR = 0 * * Get machine constants * EPS = DLAMCH( 'Epsilon' ) UNFL = DLAMCH( 'Safe minimum' ) * * If matrix lower bidiagonal, rotate to be upper bidiagonal * by applying Givens rotations on the left * IF( LOWER ) THEN DO 10 I = 1, N - 1 CALL DLARTG( D( I ), E( I ), CS, SN, R ) D( I ) = R E( I ) = SN*D( I+1 ) D( I+1 ) = CS*D( I+1 ) RWORK( I ) = CS RWORK( NM1+I ) = SN 10 CONTINUE * * Update singular vectors if desired * IF( NRU.GT.0 ) $ CALL ZLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ), $ U, LDU ) IF( NCC.GT.0 ) $ CALL ZLASR( 'L', 'V', 'F', N, NCC, RWORK( 1 ), RWORK( N ), $ C, LDC ) END IF * * Compute singular values to relative accuracy TOL * (By setting TOL to be negative, algorithm will compute * singular values to absolute accuracy ABS(TOL)*norm(input matrix)) * TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) TOL = TOLMUL*EPS * * Compute approximate maximum, minimum singular values * SMAX = ZERO DO 20 I = 1, N SMAX = MAX( SMAX, ABS( D( I ) ) ) 20 CONTINUE DO 30 I = 1, N - 1 SMAX = MAX( SMAX, ABS( E( I ) ) ) 30 CONTINUE SMINL = ZERO IF( TOL.GE.ZERO ) THEN * * Relative accuracy desired * SMINOA = ABS( D( 1 ) ) IF( SMINOA.EQ.ZERO ) $ GO TO 50 MU = SMINOA DO 40 I = 2, N MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) SMINOA = MIN( SMINOA, MU ) IF( SMINOA.EQ.ZERO ) $ GO TO 50 40 CONTINUE 50 CONTINUE SMINOA = SMINOA / SQRT( DBLE( N ) ) THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) ELSE * * Absolute accuracy desired * THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) END IF * * Prepare for main iteration loop for the singular values * (MAXIT is the maximum number of passes through the inner * loop permitted before nonconvergence signalled.) * MAXIT = MAXITR*N*N ITER = 0 OLDLL = -1 OLDM = -1 * * M points to last element of unconverged part of matrix * M = N * * Begin main iteration loop * 60 CONTINUE * * Check for convergence or exceeding iteration count * IF( M.LE.1 ) $ GO TO 160 IF( ITER.GT.MAXIT ) $ GO TO 200 * * Find diagonal block of matrix to work on * IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) $ D( M ) = ZERO SMAX = ABS( D( M ) ) SMIN = SMAX DO 70 LLL = 1, M - 1 LL = M - LLL ABSS = ABS( D( LL ) ) ABSE = ABS( E( LL ) ) IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) $ D( LL ) = ZERO IF( ABSE.LE.THRESH ) $ GO TO 80 SMIN = MIN( SMIN, ABSS ) SMAX = MAX( SMAX, ABSS, ABSE ) 70 CONTINUE LL = 0 GO TO 90 80 CONTINUE E( LL ) = ZERO * * Matrix splits since E(LL) = 0 * IF( LL.EQ.M-1 ) THEN * * Convergence of bottom singular value, return to top of loop * M = M - 1 GO TO 60 END IF 90 CONTINUE LL = LL + 1 * * E(LL) through E(M-1) are nonzero, E(LL-1) is zero * IF( LL.EQ.M-1 ) THEN * * 2 by 2 block, handle separately * CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, $ COSR, SINL, COSL ) D( M-1 ) = SIGMX E( M-1 ) = ZERO D( M ) = SIGMN * * Compute singular vectors, if desired * IF( NCVT.GT.0 ) $ CALL ZDROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, $ COSR, SINR ) IF( NRU.GT.0 ) $ CALL ZDROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) IF( NCC.GT.0 ) $ CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, $ SINL ) M = M - 2 GO TO 60 END IF * * If working on new submatrix, choose shift direction * (from larger end diagonal element towards smaller) * IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN * * Chase bulge from top (big end) to bottom (small end) * IDIR = 1 ELSE * * Chase bulge from bottom (big end) to top (small end) * IDIR = 2 END IF END IF * * Apply convergence tests * IF( IDIR.EQ.1 ) THEN * * Run convergence test in forward direction * First apply standard test to bottom of matrix * IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN E( M-1 ) = ZERO GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN * * If relative accuracy desired, * apply convergence criterion forward * MU = ABS( D( LL ) ) SMINL = MU DO 100 LLL = LL, M - 1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO GO TO 60 END IF SMINLO = SMINL MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 100 CONTINUE END IF * ELSE * * Run convergence test in backward direction * First apply standard test to top of matrix * IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN E( LL ) = ZERO GO TO 60 END IF * IF( TOL.GE.ZERO ) THEN * * If relative accuracy desired, * apply convergence criterion backward * MU = ABS( D( M ) ) SMINL = MU DO 110 LLL = M - 1, LL, -1 IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN E( LLL ) = ZERO GO TO 60 END IF SMINLO = SMINL MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) SMINL = MIN( SMINL, MU ) 110 CONTINUE END IF END IF OLDLL = LL OLDM = M * * Compute shift. First, test if shifting would ruin relative * accuracy, and if so set the shift to zero. * IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. $ MAX( EPS, HNDRTH*TOL ) ) THEN * * Use a zero shift to avoid loss of relative accuracy * SHIFT = ZERO ELSE * * Compute the shift from 2-by-2 block at end of matrix * IF( IDIR.EQ.1 ) THEN SLL = ABS( D( LL ) ) CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) ELSE SLL = ABS( D( M ) ) CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) END IF * * Test if shift negligible, and if so set to zero * IF( SLL.GT.ZERO ) THEN IF( ( SHIFT / SLL )**2.LT.EPS ) $ SHIFT = ZERO END IF END IF * * Increment iteration count * ITER = ITER + M - LL * * If SHIFT = 0, do simplified QR iteration * IF( SHIFT.EQ.ZERO ) THEN IF( IDIR.EQ.1 ) THEN * * Chase bulge from top to bottom * Save cosines and sines for later singular vector updates * CS = ONE OLDCS = ONE DO 120 I = LL, M - 1 CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) IF( I.GT.LL ) $ E( I-1 ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) RWORK( I-LL+1 ) = CS RWORK( I-LL+1+NM1 ) = SN RWORK( I-LL+1+NM12 ) = OLDCS RWORK( I-LL+1+NM13 ) = OLDSN 120 CONTINUE H = D( M )*CS D( M ) = H*OLDCS E( M-1 ) = H*OLDSN * * Update singular vectors * IF( NCVT.GT.0 ) $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ), $ RWORK( N ), VT( LL, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ), $ RWORK( NM13+1 ), U( 1, LL ), LDU ) IF( NCC.GT.0 ) $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ), $ RWORK( NM13+1 ), C( LL, 1 ), LDC ) * * Test convergence * IF( ABS( E( M-1 ) ).LE.THRESH ) $ E( M-1 ) = ZERO * ELSE * * Chase bulge from bottom to top * Save cosines and sines for later singular vector updates * CS = ONE OLDCS = ONE DO 130 I = M, LL + 1, -1 CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) IF( I.LT.M ) $ E( I ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) RWORK( I-LL ) = CS RWORK( I-LL+NM1 ) = -SN RWORK( I-LL+NM12 ) = OLDCS RWORK( I-LL+NM13 ) = -OLDSN 130 CONTINUE H = D( LL )*CS D( LL ) = H*OLDCS E( LL ) = H*OLDSN * * Update singular vectors * IF( NCVT.GT.0 ) $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ), $ RWORK( NM13+1 ), VT( LL, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ), $ RWORK( N ), U( 1, LL ), LDU ) IF( NCC.GT.0 ) $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ), $ RWORK( N ), C( LL, 1 ), LDC ) * * Test convergence * IF( ABS( E( LL ) ).LE.THRESH ) $ E( LL ) = ZERO END IF ELSE * * Use nonzero shift * IF( IDIR.EQ.1 ) THEN * * Chase bulge from top to bottom * Save cosines and sines for later singular vector updates * F = ( ABS( D( LL ) )-SHIFT )* $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) G = E( LL ) DO 140 I = LL, M - 1 CALL DLARTG( F, G, COSR, SINR, R ) IF( I.GT.LL ) $ E( I-1 ) = R F = COSR*D( I ) + SINR*E( I ) E( I ) = COSR*E( I ) - SINR*D( I ) G = SINR*D( I+1 ) D( I+1 ) = COSR*D( I+1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( I ) = R F = COSL*E( I ) + SINL*D( I+1 ) D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) IF( I.LT.M-1 ) THEN G = SINL*E( I+1 ) E( I+1 ) = COSL*E( I+1 ) END IF RWORK( I-LL+1 ) = COSR RWORK( I-LL+1+NM1 ) = SINR RWORK( I-LL+1+NM12 ) = COSL RWORK( I-LL+1+NM13 ) = SINL 140 CONTINUE E( M-1 ) = F * * Update singular vectors * IF( NCVT.GT.0 ) $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ), $ RWORK( N ), VT( LL, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ), $ RWORK( NM13+1 ), U( 1, LL ), LDU ) IF( NCC.GT.0 ) $ CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ), $ RWORK( NM13+1 ), C( LL, 1 ), LDC ) * * Test convergence * IF( ABS( E( M-1 ) ).LE.THRESH ) $ E( M-1 ) = ZERO * ELSE * * Chase bulge from bottom to top * Save cosines and sines for later singular vector updates * F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / $ D( M ) ) G = E( M-1 ) DO 150 I = M, LL + 1, -1 CALL DLARTG( F, G, COSR, SINR, R ) IF( I.LT.M ) $ E( I ) = R F = COSR*D( I ) + SINR*E( I-1 ) E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) G = SINR*D( I-1 ) D( I-1 ) = COSR*D( I-1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( I ) = R F = COSL*E( I-1 ) + SINL*D( I-1 ) D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) IF( I.GT.LL+1 ) THEN G = SINL*E( I-2 ) E( I-2 ) = COSL*E( I-2 ) END IF RWORK( I-LL ) = COSR RWORK( I-LL+NM1 ) = -SINR RWORK( I-LL+NM12 ) = COSL RWORK( I-LL+NM13 ) = -SINL 150 CONTINUE E( LL ) = F * * Test convergence * IF( ABS( E( LL ) ).LE.THRESH ) $ E( LL ) = ZERO * * Update singular vectors if desired * IF( NCVT.GT.0 ) $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ), $ RWORK( NM13+1 ), VT( LL, 1 ), LDVT ) IF( NRU.GT.0 ) $ CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ), $ RWORK( N ), U( 1, LL ), LDU ) IF( NCC.GT.0 ) $ CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ), $ RWORK( N ), C( LL, 1 ), LDC ) END IF END IF * * QR iteration finished, go back and check convergence * GO TO 60 * * All singular values converged, so make them positive * 160 CONTINUE DO 170 I = 1, N IF( D( I ).LT.ZERO ) THEN D( I ) = -D( I ) * * Change sign of singular vectors, if desired * IF( NCVT.GT.0 ) $ CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) END IF 170 CONTINUE * * Sort the singular values into decreasing order (insertion sort on * singular values, but only one transposition per singular vector) * DO 190 I = 1, N - 1 * * Scan for smallest D(I) * ISUB = 1 SMIN = D( 1 ) DO 180 J = 2, N + 1 - I IF( D( J ).LE.SMIN ) THEN ISUB = J SMIN = D( J ) END IF 180 CONTINUE IF( ISUB.NE.N+1-I ) THEN * * Swap singular values and vectors * D( ISUB ) = D( N+1-I ) D( N+1-I ) = SMIN IF( NCVT.GT.0 ) $ CALL ZSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), $ LDVT ) IF( NRU.GT.0 ) $ CALL ZSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) IF( NCC.GT.0 ) $ CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) END IF 190 CONTINUE GO TO 220 * * Maximum number of iterations exceeded, failure to converge * 200 CONTINUE INFO = 0 DO 210 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 210 CONTINUE 220 CONTINUE RETURN * * End of ZBDSQR * END SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEBRD reduces a general complex M-by-N matrix A to upper or lower * bidiagonal form B by a unitary transformation: Q**H * A * P = B. * * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. * * Arguments * ========= * * M (input) INTEGER * The number of rows in the matrix A. M >= 0. * * N (input) INTEGER * The number of columns in the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N general matrix to be reduced. * On exit, * if m >= n, the diagonal and the first superdiagonal are * overwritten with the upper bidiagonal matrix B; the * elements below the diagonal, with the array TAUQ, represent * the unitary matrix Q as a product of elementary * reflectors, and the elements above the first superdiagonal, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors; * if m < n, the diagonal and the first subdiagonal are * overwritten with the lower bidiagonal matrix B; the * elements below the first subdiagonal, with the array TAUQ, * represent the unitary matrix Q as a product of * elementary reflectors, and the elements above the diagonal, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * D (output) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the bidiagonal matrix B: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) * The off-diagonal elements of the bidiagonal matrix B: * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. * * TAUQ (output) COMPLEX*16 array dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the unitary matrix Q. See Further Details. * * TAUP (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,M,N). * For optimum performance LWORK >= (M+N)*NB, where NB * is the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrices Q and P are represented as products of elementary * reflectors: * * If m >= n, * * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, and v and u are complex * vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in * A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in * A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * If m < n, * * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, and v and u are complex * vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * The contents of A on exit are illustrated by the following examples: * * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): * * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) * ( v1 v2 v3 v4 v5 ) * * where d and e denote diagonal and off-diagonal elements of B, vi * denotes an element of the vector defining H(i), and ui an element of * the vector defining G(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB, $ NBMIN, NX DOUBLE PRECISION WS * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEBD2, ZGEMM, ZLABRD * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) ) LWKOPT = ( M+N )*NB WORK( 1 ) = DBLE( LWKOPT ) LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN INFO = -10 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZGEBRD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * WS = MAX( M, N ) LDWRKX = M LDWRKY = N * IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN * * Set the crossover point NX. * NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) ) * * Determine when to switch from blocked to unblocked code. * IF( NX.LT.MINMN ) THEN WS = ( M+N )*NB IF( LWORK.LT.WS ) THEN * * Not enough work space for the optimal NB, consider using * a smaller block size. * NBMIN = ILAENV( 2, 'ZGEBRD', ' ', M, N, -1, -1 ) IF( LWORK.GE.( M+N )*NBMIN ) THEN NB = LWORK / ( M+N ) ELSE NB = 1 NX = MINMN END IF END IF END IF ELSE NX = MINMN END IF * DO 30 I = 1, MINMN - NX, NB * * Reduce rows and columns i:i+ib-1 to bidiagonal form and return * the matrices X and Y which are needed to update the unreduced * part of the matrix * CALL ZLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, $ WORK( LDWRKX*NB+1 ), LDWRKY ) * * Update the trailing submatrix A(i+ib:m,i+ib:n), using * an update of the form A := A - V*Y' - X*U' * CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1, $ N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA, $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, $ A( I+NB, I+NB ), LDA ) CALL ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, $ ONE, A( I+NB, I+NB ), LDA ) * * Copy diagonal and off-diagonal elements of B back into A * IF( M.GE.N ) THEN DO 10 J = I, I + NB - 1 A( J, J ) = D( J ) A( J, J+1 ) = E( J ) 10 CONTINUE ELSE DO 20 J = I, I + NB - 1 A( J, J ) = D( J ) A( J+1, J ) = E( J ) 20 CONTINUE END IF 30 CONTINUE * * Use unblocked code to reduce the remainder of the matrix * CALL ZGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), $ TAUQ( I ), TAUP( I ), WORK, IINFO ) WORK( 1 ) = WS RETURN * * End of ZGEBRD * END SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGELQF computes an LQ factorization of a complex M-by-N matrix A: * A = L * Q. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N matrix A. * On exit, the elements on and below the diagonal of the array * contain the m-by-min(m,n) lower trapezoidal matrix L (L is * lower triangular if m <= n); the elements above the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,M). * For optimum performance LWORK >= M*NB, where NB is the * optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in * A(i,i+1:n), and tau in TAU(i). * * ===================================================================== * * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB, $ NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 ) LWKOPT = M*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELQF', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * K = MIN( M, N ) IF( K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1, $ -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code initially * DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) * * Compute the LQ factorization of the current block * A(i:i+ib-1,i:n) * CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H to A(i+ib:m,i:n) from the right * CALL ZLARFB( 'Right', 'No transpose', 'Forward', $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, $ WORK( IB+1 ), LDWORK ) END IF 10 CONTINUE ELSE I = 1 END IF * * Use unblocked code to factor the last or only block. * IF( I.LE.K ) $ CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * WORK( 1 ) = IWS RETURN * * End of ZGELQF * END SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER VECT INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGBR generates one of the complex unitary matrices Q or P**H * determined by ZGEBRD when reducing a complex matrix A to bidiagonal * form: A = Q * B * P**H. Q and P**H are defined as products of * elementary reflectors H(i) or G(i) respectively. * * If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q * is of order M: * if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n * columns of Q, where m >= n >= k; * if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an * M-by-M matrix. * * If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H * is of order N: * if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m * rows of P**H, where n >= m >= k; * if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as * an N-by-N matrix. * * Arguments * ========= * * VECT (input) CHARACTER*1 * Specifies whether the matrix Q or the matrix P**H is * required, as defined in the transformation applied by ZGEBRD: * = 'Q': generate Q; * = 'P': generate P**H. * * M (input) INTEGER * The number of rows of the matrix Q or P**H to be returned. * M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q or P**H to be returned. * N >= 0. * If VECT = 'Q', M >= N >= min(M,K); * if VECT = 'P', N >= M >= min(N,K). * * K (input) INTEGER * If VECT = 'Q', the number of columns in the original M-by-K * matrix reduced by ZGEBRD. * If VECT = 'P', the number of rows in the original K-by-N * matrix reduced by ZGEBRD. * K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the vectors which define the elementary reflectors, * as returned by ZGEBRD. * On exit, the M-by-N matrix Q or P**H. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= M. * * TAU (input) COMPLEX*16 array, dimension * (min(M,K)) if VECT = 'Q' * (min(N,K)) if VECT = 'P' * TAU(i) must contain the scalar factor of the elementary * reflector H(i) or G(i), which determines Q or P**H, as * returned by ZGEBRD in its array argument TAUQ or TAUP. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,min(M,N)). * For optimum performance LWORK >= min(M,N)*NB, where NB * is the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY, WANTQ INTEGER I, IINFO, J, LWKOPT, MN, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNGLQ, ZUNGQR * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 WANTQ = LSAME( VECT, 'Q' ) MN = MIN( M, N ) LQUERY = ( LWORK.EQ.-1 ) IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. $ MIN( N, K ) ) ) ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN INFO = -9 END IF * IF( INFO.EQ.0 ) THEN IF( WANTQ ) THEN NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 ) ELSE NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) END IF LWKOPT = MAX( 1, MN )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( WANTQ ) THEN * * Form Q, determined by a call to ZGEBRD to reduce an m-by-k * matrix * IF( M.GE.K ) THEN * * If m >= k, assume m >= n >= k * CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * If m < k, assume m = n * * Shift the vectors which define the elementary reflectors one * column to the right, and set the first row and column of Q * to those of the unit matrix * DO 20 J = M, 2, -1 A( 1, J ) = ZERO DO 10 I = J + 1, M A( I, J ) = A( I, J-1 ) 10 CONTINUE 20 CONTINUE A( 1, 1 ) = ONE DO 30 I = 2, M A( I, 1 ) = ZERO 30 CONTINUE IF( M.GT.1 ) THEN * * Form Q(2:m,2:m) * CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF ELSE * * Form P', determined by a call to ZGEBRD to reduce a k-by-n * matrix * IF( K.LT.N ) THEN * * If k < n, assume k <= m <= n * CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) * ELSE * * If k >= n, assume m = n * * Shift the vectors which define the elementary reflectors one * row downward, and set the first row and column of P' to * those of the unit matrix * A( 1, 1 ) = ONE DO 40 I = 2, N A( I, 1 ) = ZERO 40 CONTINUE DO 60 J = 2, N DO 50 I = J - 1, 2, -1 A( I, J ) = A( I-1, J ) 50 CONTINUE A( 1, J ) = ZERO 60 CONTINUE IF( N.GT.1 ) THEN * * Form P'(2:n,2:n) * CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, $ LWORK, IINFO ) END IF END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNGBR * END SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows, * which is defined as the first M rows of a product of K elementary * reflectors of order N * * Q = H(k)' . . . H(2)' H(1)' * * as returned by ZGELQF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. N >= M. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. M >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the i-th row must contain the vector which defines * the elementary reflector H(i), for i = 1,2,...,k, as returned * by ZGELQF in the first k rows of its array argument A. * On exit, the M-by-N matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK >= max(1,M). * For optimum performance LWORK >= M*NB, where NB is * the optimal blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit; * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, $ LWKOPT, NB, NBMIN, NX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNGL2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 ) LWKOPT = MAX( 1, M )*NB WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.LE.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 NX = 0 IWS = M IF( NB.GT.1 .AND. NB.LT.K ) THEN * * Determine when to cross over from blocked to unblocked code. * NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) ) IF( NX.LT.K ) THEN * * Determine if workspace is large enough for blocked code. * LDWORK = M IWS = LDWORK*NB IF( LWORK.LT.IWS ) THEN * * Not enough workspace to use optimal NB: reduce NB and * determine the minimum value of NB. * NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) ) END IF END IF END IF * IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN * * Use blocked code after the last block. * The first kk rows are handled by the block method. * KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) * * Set A(kk+1:m,1:kk) to zero. * DO 20 J = 1, KK DO 10 I = KK + 1, M A( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE KK = 0 END IF * * Use unblocked code for the last or only block. * IF( KK.LT.M ) $ CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, $ TAU( KK+1 ), WORK, IINFO ) * IF( KK.GT.0 ) THEN * * Use blocked code * DO 50 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF( I+IB.LE.M ) THEN * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), $ LDA, TAU( I ), WORK, LDWORK ) * * Apply H' to A(i+ib:m,i:n) from the right * CALL ZLARFB( 'Right', 'Conjugate transpose', 'Forward', $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, $ WORK( IB+1 ), LDWORK ) END IF * * Apply H' to columns i:n of current block * CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, $ IINFO ) * * Set columns 1:i-1 of current block to zero * DO 40 J = 1, I - 1 DO 30 L = I, I + IB - 1 A( L, J ) = ZERO 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF * WORK( 1 ) = IWS RETURN * * End of ZUNGLQ * END SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C * with * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'C': Q**H * C C * Q**H * * If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C * with * SIDE = 'L' SIDE = 'R' * TRANS = 'N': P * C C * P * TRANS = 'C': P**H * C C * P**H * * Here Q and P**H are the unitary matrices determined by ZGEBRD when * reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q * and P**H are defined as products of elementary reflectors H(i) and * G(i) respectively. * * Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the * order of the unitary matrix Q or P**H that is applied. * * If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: * if nq >= k, Q = H(1) H(2) . . . H(k); * if nq < k, Q = H(1) H(2) . . . H(nq-1). * * If VECT = 'P', A is assumed to have been a K-by-NQ matrix: * if k < nq, P = G(1) G(2) . . . G(k); * if k >= nq, P = G(1) G(2) . . . G(nq-1). * * Arguments * ========= * * VECT (input) CHARACTER*1 * = 'Q': apply Q or Q**H; * = 'P': apply P or P**H. * * SIDE (input) CHARACTER*1 * = 'L': apply Q, Q**H, P or P**H from the Left; * = 'R': apply Q, Q**H, P or P**H from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q or P; * = 'C': Conjugate transpose, apply Q**H or P**H. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * If VECT = 'Q', the number of columns in the original * matrix reduced by ZGEBRD. * If VECT = 'P', the number of rows in the original * matrix reduced by ZGEBRD. * K >= 0. * * A (input) COMPLEX*16 array, dimension * (LDA,min(nq,K)) if VECT = 'Q' * (LDA,nq) if VECT = 'P' * The vectors which define the elementary reflectors H(i) and * G(i), whose products determine the matrices Q and P, as * returned by ZGEBRD. * * LDA (input) INTEGER * The leading dimension of the array A. * If VECT = 'Q', LDA >= max(1,nq); * if VECT = 'P', LDA >= max(1,min(nq,K)). * * TAU (input) COMPLEX*16 array, dimension (min(nq,K)) * TAU(i) must contain the scalar factor of the elementary * reflector H(i) or G(i) which determines Q or P, as returned * by ZGEBRD in the array argument TAUQ or TAUP. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q * or P*C or P**H*C or C*P or C*P**H. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZUNMLQ, ZUNMQR * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 APPLYQ = LSAME( VECT, 'Q' ) LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q or P and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( K.LT.0 ) THEN INFO = -6 ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) $ THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -13 END IF * IF( INFO.EQ.0 ) THEN IF( APPLYQ ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMBR', -INFO ) RETURN ELSE IF( LQUERY ) THEN END IF * * Quick return if possible * WORK( 1 ) = 1 IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * IF( APPLYQ ) THEN * * Apply Q * IF( NQ.GE.K ) THEN * * Q was determined by a call to ZGEBRD with nq >= k * CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * Q was determined by a call to ZGEBRD with nq < k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF ELSE * * Apply P * IF( NOTRAN ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF IF( NQ.GT.K ) THEN * * P was determined by a call to ZGEBRD with nq > k * CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, IINFO ) ELSE IF( NQ.GT.1 ) THEN * * P was determined by a call to ZGEBRD with nq <= k * IF( LEFT ) THEN MI = M - 1 NI = N I1 = 2 I2 = 1 ELSE MI = M NI = N - 1 I1 = 1 I2 = 2 END IF CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMBR * END SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. DOUBLE PRECISION F, G, H, SSMAX, SSMIN * .. * * Purpose * ======= * * DLAS2 computes the singular values of the 2-by-2 matrix * [ F G ] * [ 0 H ]. * On return, SSMIN is the smaller singular value and SSMAX is the * larger singular value. * * Arguments * ========= * * F (input) DOUBLE PRECISION * The (1,1) element of the 2-by-2 matrix. * * G (input) DOUBLE PRECISION * The (1,2) element of the 2-by-2 matrix. * * H (input) DOUBLE PRECISION * The (2,2) element of the 2-by-2 matrix. * * SSMIN (output) DOUBLE PRECISION * The smaller singular value. * * SSMAX (output) DOUBLE PRECISION * The larger singular value. * * Further Details * =============== * * Barring over/underflow, all output quantities are correct to within * a few units in the last place (ulps), even in the absence of a guard * digit in addition/subtraction. * * In IEEE arithmetic, the code works correctly if one matrix element is * infinite. * * Overflow will not occur unless the largest singular value itself * overflows, or is within a few ulps of overflow. (On machines with * partial overflow, like the Cray, overflow may occur if the largest * singular value is within a factor of 2 of overflow.) * * Underflow is harmless if underflow is gradual. Otherwise, results * may correspond to a matrix modified by perturbations of size near * the underflow threshold. * * ==================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * FA = ABS( F ) GA = ABS( G ) HA = ABS( H ) FHMN = MIN( FA, HA ) FHMX = MAX( FA, HA ) IF( FHMN.EQ.ZERO ) THEN SSMIN = ZERO IF( FHMX.EQ.ZERO ) THEN SSMAX = GA ELSE SSMAX = MAX( FHMX, GA )*SQRT( ONE+ $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) END IF ELSE IF( GA.LT.FHMX ) THEN AS = ONE + FHMN / FHMX AT = ( FHMX-FHMN ) / FHMX AU = ( GA / FHMX )**2 C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) SSMIN = FHMN*C SSMAX = FHMX / C ELSE AU = FHMX / GA IF( AU.EQ.ZERO ) THEN * * Avoid possible harmful underflow if exponent range * asymmetric (true SSMIN may not underflow even if * AU underflows) * SSMIN = ( FHMN*FHMX ) / GA SSMAX = GA ELSE AS = ONE + FHMN / FHMX AT = ( FHMX-FHMN ) / FHMX C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ $ SQRT( ONE+( AT*AU )**2 ) ) SSMIN = ( FHMN*C )*AU SSMIN = SSMIN + SSMIN SSMAX = GA / ( C+C ) END IF END IF END IF RETURN * * End of DLAS2 * END SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1999 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ) * .. * * Purpose * ======= * * DLASQ1 computes the singular values of a real N-by-N bidiagonal * matrix with diagonal D and off-diagonal E. The singular values * are computed to high relative accuracy, in the absence of * denormalization, underflow and overflow. The algorithm was first * presented in * * "Accurate singular values and differential qd algorithms" by K. V. * Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, * 1994, * * and the present implementation is described in "An implementation of * the dqds Algorithm (Positive Case)", LAPACK Working Note. * * Arguments * ========= * * N (input) INTEGER * The number of rows and columns in the matrix. N >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, D contains the diagonal elements of the * bidiagonal matrix whose SVD is desired. On normal exit, * D contains the singular values in decreasing order. * * E (input/output) DOUBLE PRECISION array, dimension (N) * On entry, elements E(1:N-1) contain the off-diagonal elements * of the bidiagonal matrix whose SVD is desired. * On exit, E is overwritten. * * WORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: the algorithm failed * = 1, a split was marked by a positive value in E * = 2, current block of Z not diagonalized after 30*N * iterations (in inner while loop) * = 3, termination criterion of outer while loop not met * (program created more than N unreduced blocks) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. INTEGER I, IINFO DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX * .. * .. External Subroutines .. EXTERNAL DLAS2, DLASQ2, DLASRT, XERBLA * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -2 CALL XERBLA( 'DLASQ1', -INFO ) RETURN ELSE IF( N.EQ.0 ) THEN RETURN ELSE IF( N.EQ.1 ) THEN D( 1 ) = ABS( D( 1 ) ) RETURN ELSE IF( N.EQ.2 ) THEN CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) D( 1 ) = SIGMX D( 2 ) = SIGMN RETURN END IF * * Estimate the largest singular value. * SIGMX = ZERO DO 10 I = 1, N - 1 D( I ) = ABS( D( I ) ) SIGMX = MAX( SIGMX, ABS( E( I ) ) ) 10 CONTINUE D( N ) = ABS( D( N ) ) * * Early return if SIGMX is zero (matrix is already diagonal). * IF( SIGMX.EQ.ZERO ) THEN CALL DLASRT( 'D', N, D, IINFO ) RETURN END IF * DO 20 I = 1, N SIGMX = MAX( SIGMX, D( I ) ) 20 CONTINUE * * Copy D and E into WORK (in the Z format) and scale (squaring the * input data makes scaling by a power of the radix pointless). * EPS = DLAMCH( 'Precision' ) SAFMIN = DLAMCH( 'Safe minimum' ) SCALE = SQRT( EPS / SAFMIN ) CALL DCOPY( N, D, 1, WORK( 1 ), 2 ) CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 ) CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1, $ IINFO ) * * Compute the q's and e's. * DO 30 I = 1, 2*N - 1 WORK( I ) = WORK( I )**2 30 CONTINUE WORK( 2*N ) = ZERO * CALL DLASQ2( N, WORK, INFO ) * IF( INFO.EQ.0 ) THEN DO 40 I = 1, N D( I ) = SQRT( WORK( I ) ) 40 CONTINUE CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO ) END IF * RETURN * * End of DLASQ1 * END SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN * .. * * Purpose * ======= * * DLASV2 computes the singular value decomposition of a 2-by-2 * triangular matrix * [ F G ] * [ 0 H ]. * On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the * smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and * right singular vectors for abs(SSMAX), giving the decomposition * * [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] * [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. * * Arguments * ========= * * F (input) DOUBLE PRECISION * The (1,1) element of the 2-by-2 matrix. * * G (input) DOUBLE PRECISION * The (1,2) element of the 2-by-2 matrix. * * H (input) DOUBLE PRECISION * The (2,2) element of the 2-by-2 matrix. * * SSMIN (output) DOUBLE PRECISION * abs(SSMIN) is the smaller singular value. * * SSMAX (output) DOUBLE PRECISION * abs(SSMAX) is the larger singular value. * * SNL (output) DOUBLE PRECISION * CSL (output) DOUBLE PRECISION * The vector (CSL, SNL) is a unit left singular vector for the * singular value abs(SSMAX). * * SNR (output) DOUBLE PRECISION * CSR (output) DOUBLE PRECISION * The vector (CSR, SNR) is a unit right singular vector for the * singular value abs(SSMAX). * * Further Details * =============== * * Any input parameter may be aliased with any output parameter. * * Barring over/underflow and assuming a guard digit in subtraction, all * output quantities are correct to within a few units in the last * place (ulps). * * In IEEE arithmetic, the code works correctly if one matrix element is * infinite. * * Overflow will not occur unless the largest singular value itself * overflows or is within a few ulps of overflow. (On machines with * partial overflow, like the Cray, overflow may occur if the largest * singular value is within a factor of 2 of overflow.) * * Underflow is harmless if underflow is gradual. Otherwise, results * may correspond to a matrix modified by perturbations of size near * the underflow threshold. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION FOUR PARAMETER ( FOUR = 4.0D0 ) * .. * .. Local Scalars .. LOGICAL GASMAL, SWAP INTEGER PMAX DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Executable Statements .. * FT = F FA = ABS( FT ) HT = H HA = ABS( H ) * * PMAX points to the maximum absolute element of matrix * PMAX = 1 if F largest in absolute values * PMAX = 2 if G largest in absolute values * PMAX = 3 if H largest in absolute values * PMAX = 1 SWAP = ( HA.GT.FA ) IF( SWAP ) THEN PMAX = 3 TEMP = FT FT = HT HT = TEMP TEMP = FA FA = HA HA = TEMP * * Now FA .ge. HA * END IF GT = G GA = ABS( GT ) IF( GA.EQ.ZERO ) THEN * * Diagonal matrix * SSMIN = HA SSMAX = FA CLT = ONE CRT = ONE SLT = ZERO SRT = ZERO ELSE GASMAL = .TRUE. IF( GA.GT.FA ) THEN PMAX = 2 IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN * * Case of very large GA * GASMAL = .FALSE. SSMAX = GA IF( HA.GT.ONE ) THEN SSMIN = FA / ( GA / HA ) ELSE SSMIN = ( FA / GA )*HA END IF CLT = ONE SLT = HT / GT SRT = ONE CRT = FT / GT END IF END IF IF( GASMAL ) THEN * * Normal case * D = FA - HA IF( D.EQ.FA ) THEN * * Copes with infinite F or H * L = ONE ELSE L = D / FA END IF * * Note that 0 .le. L .le. 1 * M = GT / FT * * Note that abs(M) .le. 1/macheps * T = TWO - L * * Note that T .ge. 1 * MM = M*M TT = T*T S = SQRT( TT+MM ) * * Note that 1 .le. S .le. 1 + 1/macheps * IF( L.EQ.ZERO ) THEN R = ABS( M ) ELSE R = SQRT( L*L+MM ) END IF * * Note that 0 .le. R .le. 1 + 1/macheps * A = HALF*( S+R ) * * Note that 1 .le. A .le. 1 + abs(M) * SSMIN = HA / A SSMAX = FA*A IF( MM.EQ.ZERO ) THEN * * Note that M is very tiny * IF( L.EQ.ZERO ) THEN T = SIGN( TWO, FT )*SIGN( ONE, GT ) ELSE T = GT / SIGN( D, FT ) + M / T END IF ELSE T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) END IF L = SQRT( T*T+FOUR ) CRT = TWO / L SRT = T / L CLT = ( CRT+SRT*M ) / A SLT = ( HT / FT )*SRT / A END IF END IF IF( SWAP ) THEN CSL = SRT SNL = CRT CSR = SLT SNR = CLT ELSE CSL = CLT SNL = SLT CSR = CRT SNR = SRT END IF * * Correct signs of SSMAX and SSMIN * IF( PMAX.EQ.1 ) $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) IF( PMAX.EQ.2 ) $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) IF( PMAX.EQ.3 ) $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) SSMAX = SIGN( SSMAX, TSIGN ) SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) RETURN * * End of DLASV2 * END SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S ) * * applies a plane rotation, where the cos and sin (c and s) are real * and the vectors cx and cy are complex. * jack dongarra, linpack, 3/11/78. * * .. Scalar Arguments .. INTEGER INCX, INCY, N DOUBLE PRECISION C, S * .. * .. Array Arguments .. COMPLEX*16 CX( * ), CY( * ) * * ===================================================================== * .. * .. Local Scalars .. INTEGER I, IX, IY COMPLEX*16 CTEMP * .. * .. Executable Statements .. * IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 .AND. INCY.EQ.1 ) $ GO TO 20 * * code for unequal increments or equal increments not equal * to 1 * IX = 1 IY = 1 IF( INCX.LT.0 ) $ IX = ( -N+1 )*INCX + 1 IF( INCY.LT.0 ) $ IY = ( -N+1 )*INCY + 1 DO 10 I = 1, N CTEMP = C*CX( IX ) + S*CY( IY ) CY( IY ) = C*CY( IY ) - S*CX( IX ) CX( IX ) = CTEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * * code for both increments equal to 1 * 20 CONTINUE DO 30 I = 1, N CTEMP = C*CX( I ) + S*CY( I ) CY( I ) = C*CY( I ) - S*CX( I ) CX( I ) = CTEMP 30 CONTINUE RETURN END SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEBD2 reduces a complex general m by n matrix A to upper or lower * real bidiagonal form B by a unitary transformation: Q' * A * P = B. * * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. * * Arguments * ========= * * M (input) INTEGER * The number of rows in the matrix A. M >= 0. * * N (input) INTEGER * The number of columns in the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n general matrix to be reduced. * On exit, * if m >= n, the diagonal and the first superdiagonal are * overwritten with the upper bidiagonal matrix B; the * elements below the diagonal, with the array TAUQ, represent * the unitary matrix Q as a product of elementary * reflectors, and the elements above the first superdiagonal, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors; * if m < n, the diagonal and the first subdiagonal are * overwritten with the lower bidiagonal matrix B; the * elements below the first subdiagonal, with the array TAUQ, * represent the unitary matrix Q as a product of * elementary reflectors, and the elements above the diagonal, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * D (output) DOUBLE PRECISION array, dimension (min(M,N)) * The diagonal elements of the bidiagonal matrix B: * D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) * The off-diagonal elements of the bidiagonal matrix B: * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. * * TAUQ (output) COMPLEX*16 array dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the unitary matrix Q. See Further Details. * * TAUP (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * * WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value. * * Further Details * =============== * * The matrices Q and P are represented as products of elementary * reflectors: * * If m >= n, * * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, and v and u are complex * vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in * A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in * A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * If m < n, * * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, v and u are complex vectors; * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); * tauq is stored in TAUQ(i) and taup in TAUP(i). * * The contents of A on exit are illustrated by the following examples: * * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): * * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) * ( v1 v2 v3 v4 v5 ) * * where d and e denote diagonal and off-diagonal elements of B, vi * denotes an element of the vector defining H(i), and ui an element of * the vector defining G(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.LT.0 ) THEN CALL XERBLA( 'ZGEBD2', -INFO ) RETURN END IF * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, N * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * ALPHA = A( I, I ) CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = ALPHA A( I, I ) = ONE * * Apply H(i)' to A(i:m,i+1:n) from the left * CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN * * Generate elementary reflector G(i) to annihilate * A(i,i+2:n) * CALL ZLACGV( N-I, A( I, I+1 ), LDA ) ALPHA = A( I, I+1 ) CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, $ TAUP( I ) ) E( I ) = ALPHA A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) A( I, I+1 ) = E( I ) ELSE TAUP( I ) = ZERO END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, M * * Generate elementary reflector G(i) to annihilate A(i,i+1:n) * CALL ZLACGV( N-I+1, A( I, I ), LDA ) ALPHA = A( I, I ) CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = ALPHA A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), $ A( MIN( I+1, M ), I ), LDA, WORK ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * IF( I.LT.M ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:m,i) * ALPHA = A( I+1, I ) CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = ALPHA A( I+1, I ) = ONE * * Apply H(i)' to A(i+1:m,i+1:n) from the left * CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1, $ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, $ WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO END IF 20 CONTINUE END IF RETURN * * End of ZGEBD2 * END SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGELQ2 computes an LQ factorization of a complex m by n matrix A: * A = L * Q. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and below the diagonal of the array * contain the m by min(m,n) lower trapezoidal matrix L (L is * lower triangular if m <= n); the elements above the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX*16 array, dimension (M) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in * A(i,i+1:n), and tau in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGELQ2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL ZLACGV( N-I+1, A( I, I ), LDA ) ALPHA = A( I, I ) CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAU( I ) ) IF( I.LT.M ) THEN * * Apply H(i) to A(i+1:m,i:n) from the right * A( I, I ) = ONE CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), $ A( I+1, I ), LDA, WORK ) END IF A( I, I ) = ALPHA CALL ZLACGV( N-I+1, A( I, I ), LDA ) 10 CONTINUE RETURN * * End of ZGELQ2 * END SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER LDA, LDX, LDY, M, N, NB * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), $ Y( LDY, * ) * .. * * Purpose * ======= * * ZLABRD reduces the first NB rows and columns of a complex general * m by n matrix A to upper or lower real bidiagonal form by a unitary * transformation Q' * A * P, and returns the matrices X and Y which * are needed to apply the transformation to the unreduced part of A. * * If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower * bidiagonal form. * * This is an auxiliary routine called by ZGEBRD * * Arguments * ========= * * M (input) INTEGER * The number of rows in the matrix A. * * N (input) INTEGER * The number of columns in the matrix A. * * NB (input) INTEGER * The number of leading rows and columns of A to be reduced. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n general matrix to be reduced. * On exit, the first NB rows and columns of the matrix are * overwritten; the rest of the array is unchanged. * If m >= n, elements on and below the diagonal in the first NB * columns, with the array TAUQ, represent the unitary * matrix Q as a product of elementary reflectors; and * elements above the diagonal in the first NB rows, with the * array TAUP, represent the unitary matrix P as a product * of elementary reflectors. * If m < n, elements below the diagonal in the first NB * columns, with the array TAUQ, represent the unitary * matrix Q as a product of elementary reflectors, and * elements on and above the diagonal in the first NB rows, * with the array TAUP, represent the unitary matrix P as * a product of elementary reflectors. * See Further Details. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * D (output) DOUBLE PRECISION array, dimension (NB) * The diagonal elements of the first NB rows and columns of * the reduced matrix. D(i) = A(i,i). * * E (output) DOUBLE PRECISION array, dimension (NB) * The off-diagonal elements of the first NB rows and columns of * the reduced matrix. * * TAUQ (output) COMPLEX*16 array dimension (NB) * The scalar factors of the elementary reflectors which * represent the unitary matrix Q. See Further Details. * * TAUP (output) COMPLEX*16 array, dimension (NB) * The scalar factors of the elementary reflectors which * represent the unitary matrix P. See Further Details. * * X (output) COMPLEX*16 array, dimension (LDX,NB) * The m-by-nb matrix X required to update the unreduced part * of A. * * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(1,M). * * Y (output) COMPLEX*16 array, dimension (LDY,NB) * The n-by-nb matrix Y required to update the unreduced part * of A. * * LDY (output) INTEGER * The leading dimension of the array Y. LDY >= max(1,N). * * Further Details * =============== * * The matrices Q and P are represented as products of elementary * reflectors: * * Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) * * Each H(i) and G(i) has the form: * * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' * * where tauq and taup are complex scalars, and v and u are complex * vectors. * * If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in * A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). * * The elements of the vectors v and u together form the m-by-nb matrix * V and the nb-by-n matrix U' which are needed, with X and Y, to apply * the transformation to the unreduced part of the matrix, using a block * update of the form: A := A - V*Y' - X*U'. * * The contents of A on exit are illustrated by the following examples * with nb = 2: * * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): * * ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) * ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) * ( v1 v2 a a a ) ( v1 1 a a a a ) * ( v1 v2 a a a ) ( v1 v2 a a a a ) * ( v1 v2 a a a ) ( v1 v2 a a a a ) * ( v1 v2 a a a ) * * where a denotes an element of the original matrix which is unchanged, * vi denotes an element of the vector defining H(i), and ui an element * of the vector defining G(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) $ RETURN * IF( M.GE.N ) THEN * * Reduce to upper bidiagonal form * DO 10 I = 1, NB * * Update A(i:m,i) * CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+1:m,i) * ALPHA = A( I, I ) CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = ALPHA IF( I.LT.N ) THEN A( I, I ) = ONE * * Compute Y(i+1:n,i) * CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE, $ A( I, I+1 ), LDA, A( I, I ), 1, ZERO, $ Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, $ A( I, 1 ), LDA, A( I, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE, $ X( I, 1 ), LDX, A( I, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, $ Y( I+1, I ), 1 ) CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) * * Update A(i,i+1:n) * CALL ZLACGV( N-I, A( I, I+1 ), LDA ) CALL ZLACGV( I, A( I, 1 ), LDA ) CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) CALL ZLACGV( I, A( I, 1 ), LDA ) CALL ZLACGV( I-1, X( I, 1 ), LDX ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE, $ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE, $ A( I, I+1 ), LDA ) CALL ZLACGV( I-1, X( I, 1 ), LDX ) * * Generate reflection P(i) to annihilate A(i,i+2:n) * ALPHA = A( I, I+1 ) CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, $ TAUP( I ) ) E( I ) = ALPHA A( I, I+1 ) = ONE * * Compute X(i+1:m,i) * CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE, $ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO, $ X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) END IF 10 CONTINUE ELSE * * Reduce to lower bidiagonal form * DO 20 I = 1, NB * * Update A(i,i:n) * CALL ZLACGV( N-I+1, A( I, I ), LDA ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) CALL ZLACGV( I-1, A( I, 1 ), LDA ) CALL ZLACGV( I-1, X( I, 1 ), LDX ) CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE, $ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ), $ LDA ) CALL ZLACGV( I-1, X( I, 1 ), LDX ) * * Generate reflection P(i) to annihilate A(i,i+1:n) * ALPHA = A( I, I ) CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = ALPHA IF( I.LT.M ) THEN A( I, I ) = ONE * * Compute X(i+1:m,i) * CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE, $ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO, $ X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) CALL ZLACGV( N-I+1, A( I, I ), LDA ) * * Update A(i+1:m,i) * CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) CALL ZLACGV( I-1, Y( I, 1 ), LDY ) CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) * * Generate reflection Q(i) to annihilate A(i+2:m,i) * ALPHA = A( I+1, I ) CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = ALPHA A( I+1, I ) = ONE * * Compute Y(i+1:n,i) * CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE, $ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO, $ Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE, $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE, $ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO, $ Y( 1, I ), 1 ) CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE, $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE, $ Y( I+1, I ), 1 ) CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) ELSE CALL ZLACGV( N-I+1, A( I, I ), LDA ) END IF 20 CONTINUE END IF RETURN * * End of ZLABRD * END SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, * which is defined as the first m rows of a product of k elementary * reflectors of order n * * Q = H(k)' . . . H(2)' H(1)' * * as returned by ZGELQF. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix Q. M >= 0. * * N (input) INTEGER * The number of columns of the matrix Q. N >= M. * * K (input) INTEGER * The number of elementary reflectors whose product defines the * matrix Q. M >= K >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the i-th row must contain the vector which defines * the elementary reflector H(i), for i = 1,2,...,k, as returned * by ZGELQF in the first k rows of its array argument A. * On exit, the m by n matrix Q. * * LDA (input) INTEGER * The first dimension of the array A. LDA >= max(1,M). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * * WORK (workspace) COMPLEX*16 array, dimension (M) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument has an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, L * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNGL2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.LE.0 ) $ RETURN * IF( K.LT.M ) THEN * * Initialise rows k+1:m to rows of the unit matrix * DO 20 J = 1, N DO 10 L = K + 1, M A( L, J ) = ZERO 10 CONTINUE IF( J.GT.K .AND. J.LE.M ) $ A( J, J ) = ONE 20 CONTINUE END IF * DO 40 I = K, 1, -1 * * Apply H(i)' to A(i:m,i:n) from the right * IF( I.LT.N ) THEN CALL ZLACGV( N-I, A( I, I+1 ), LDA ) IF( I.LT.M ) THEN A( I, I ) = ONE CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, $ DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) END IF CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) CALL ZLACGV( N-I, A( I, I+1 ), LDA ) END IF A( I, I ) = ONE - DCONJG( TAU( I ) ) * * Set A(i,1:i-1) to zero * DO 30 L = 1, I - 1 A( I, L ) = ZERO 30 CONTINUE 40 CONTINUE RETURN * * End of ZUNGL2 * END SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNMLQ overwrites the general complex M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'C': Q**H * C C * Q**H * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(k)' . . . H(2)' H(1)' * * as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**H from the Left; * = 'R': apply Q or Q**H from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'C': Conjugate transpose, apply Q**H. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension * (LDA,M) if SIDE = 'L', * (LDA,N) if SIDE = 'R' * The i-th row must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGELQF in the first k rows of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,K). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN CHARACTER TRANST INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. COMPLEX*16 T( LDT, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARFB, ZLARFT, ZUNML2 * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. NB may be at most NBMAX, where NBMAX * is used to define the local array T. * NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNMLQ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IWS = NW*NB IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K, $ -1 ) ) END IF ELSE IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * IF( NOTRAN ) THEN TRANST = 'C' ELSE TRANST = 'N' END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), T, LDT ) IF( LEFT ) THEN * * H or H' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H' * CALL ZLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, $ LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of ZUNMLQ * END SUBROUTINE DLASQ2( N, Z, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1999 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * Purpose * ======= * * DLASQ2 computes all the eigenvalues of the symmetric positive * definite tridiagonal matrix associated with the qd array Z to high * relative accuracy are computed to high relative accuracy, in the * absence of denormalization, underflow and overflow. * * To see the relation of Z to the tridiagonal matrix, let L be a * unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and * let U be an upper bidiagonal matrix with 1's above and diagonal * Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the * symmetric tridiagonal to which it is similar. * * Note : DLASQ2 defines a logical variable, IEEE, which is true * on machines which follow ieee-754 floating-point standard in their * handling of infinities and NaNs, and false otherwise. This variable * is passed to DLASQ3. * * Arguments * ========= * * N (input) INTEGER * The number of rows and columns in the matrix. N >= 0. * * Z (workspace) DOUBLE PRECISION array, dimension ( 4*N ) * On entry Z holds the qd array. On exit, entries 1 to N hold * the eigenvalues in decreasing order, Z( 2*N+1 ) holds the * trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If * N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) * holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of * shifts that failed. * * INFO (output) INTEGER * = 0: successful exit * < 0: if the i-th argument is a scalar and had an illegal * value, then INFO = -i, if the i-th argument is an * array and the j-entry had an illegal value, then * INFO = -(i*100+j) * > 0: the algorithm failed * = 1, a split was marked by a positive value in E * = 2, current block of Z not diagonalized after 30*N * iterations (in inner while loop) * = 3, termination criterion of outer while loop not met * (program created more than N unreduced blocks) * * Further Details * =============== * Local Variables: I0:N0 defines a current unreduced segment of Z. * The shifts are accumulated in SIGMA. Iteration count is in ITER. * Ping-pong is controlled by PP (alternates between 0 and 1). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION CBIAS PARAMETER ( CBIAS = 1.50D0 ) DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, $ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 ) * .. * .. Local Scalars .. LOGICAL IEEE INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, $ N0, NBIG, NDIV, NFAIL, PP, SPLT DOUBLE PRECISION D, DESIG, DMIN, E, EMAX, EMIN, EPS, OLDEMN, $ QMAX, QMIN, S, SAFMIN, SIGMA, T, TEMP, TOL, $ TOL2, TRACE, ZMAX * .. * .. External Subroutines .. EXTERNAL DLASQ3, DLASRT, XERBLA * .. * .. External Functions .. INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, ILAENV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input arguments. * (in case DLASQ2 is not called by DLASQ1) * INFO = 0 EPS = DLAMCH( 'Precision' ) SAFMIN = DLAMCH( 'Safe minimum' ) TOL = EPS*HUNDRD TOL2 = TOL**2 * IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DLASQ2', 1 ) RETURN ELSE IF( N.EQ.0 ) THEN RETURN ELSE IF( N.EQ.1 ) THEN * * 1-by-1 case. * IF( Z( 1 ).LT.ZERO ) THEN INFO = -201 CALL XERBLA( 'DLASQ2', 2 ) END IF RETURN ELSE IF( N.EQ.2 ) THEN * * 2-by-2 case. * IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN INFO = -2 CALL XERBLA( 'DLASQ2', 2 ) RETURN ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN D = Z( 3 ) Z( 3 ) = Z( 1 ) Z( 1 ) = D END IF Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 ) IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) S = Z( 3 )*( Z( 2 ) / T ) IF( S.LE.T ) THEN S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) ) ELSE S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) END IF T = Z( 1 ) + ( S+Z( 2 ) ) Z( 3 ) = Z( 3 )*( Z( 1 ) / T ) Z( 1 ) = T END IF Z( 2 ) = Z( 3 ) Z( 6 ) = Z( 2 ) + Z( 1 ) RETURN END IF * * Check for negative data and compute sums of q's and e's. * Z( 2*N ) = ZERO EMIN = Z( 2 ) QMAX = ZERO ZMAX = ZERO D = ZERO E = ZERO * DO 10 K = 1, 2*( N-1 ), 2 IF( Z( K ).LT.ZERO ) THEN INFO = -( 200+K ) CALL XERBLA( 'DLASQ2', 2 ) RETURN ELSE IF( Z( K+1 ).LT.ZERO ) THEN INFO = -( 200+K+1 ) CALL XERBLA( 'DLASQ2', 2 ) RETURN END IF D = D + Z( K ) E = E + Z( K+1 ) QMAX = MAX( QMAX, Z( K ) ) EMIN = MIN( EMIN, Z( K+1 ) ) ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) ) 10 CONTINUE IF( Z( 2*N-1 ).LT.ZERO ) THEN INFO = -( 200+2*N-1 ) CALL XERBLA( 'DLASQ2', 2 ) RETURN END IF D = D + Z( 2*N-1 ) QMAX = MAX( QMAX, Z( 2*N-1 ) ) ZMAX = MAX( QMAX, ZMAX ) * * Check for diagonality. * IF( E.EQ.ZERO ) THEN DO 20 K = 2, N Z( K ) = Z( 2*K-1 ) 20 CONTINUE CALL DLASRT( 'D', N, Z, IINFO ) Z( 2*N-1 ) = D RETURN END IF * TRACE = D + E * * Check for zero data. * IF( TRACE.EQ.ZERO ) THEN Z( 2*N-1 ) = ZERO RETURN END IF * * Check whether the machine is IEEE conformable. * IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 * * Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). * DO 30 K = 2*N, 2, -2 Z( 2*K ) = ZERO Z( 2*K-1 ) = Z( K ) Z( 2*K-2 ) = ZERO Z( 2*K-3 ) = Z( K-1 ) 30 CONTINUE * I0 = 1 N0 = N * * Reverse the qd-array, if warranted. * IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN IPN4 = 4*( I0+N0 ) DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4 TEMP = Z( I4-3 ) Z( I4-3 ) = Z( IPN4-I4-3 ) Z( IPN4-I4-3 ) = TEMP TEMP = Z( I4-1 ) Z( I4-1 ) = Z( IPN4-I4-5 ) Z( IPN4-I4-5 ) = TEMP 40 CONTINUE END IF * * Initial split checking via dqd and Li's test. * PP = 0 * DO 80 K = 1, 2 * D = Z( 4*N0+PP-3 ) DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4 IF( Z( I4-1 ).LE.TOL2*D ) THEN Z( I4-1 ) = -ZERO D = Z( I4-3 ) ELSE D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) ) END IF 50 CONTINUE * * dqd maps Z to ZZ plus Li's test. * EMIN = Z( 4*I0+PP+1 ) D = Z( 4*I0+PP-3 ) DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4 Z( I4-2*PP-2 ) = D + Z( I4-1 ) IF( Z( I4-1 ).LE.TOL2*D ) THEN Z( I4-1 ) = -ZERO Z( I4-2*PP-2 ) = D Z( I4-2*PP ) = ZERO D = Z( I4+1 ) ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND. $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN TEMP = Z( I4+1 ) / Z( I4-2*PP-2 ) Z( I4-2*PP ) = Z( I4-1 )*TEMP D = D*TEMP ELSE Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) ) D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) ) END IF EMIN = MIN( EMIN, Z( I4-2*PP ) ) 60 CONTINUE Z( 4*N0-PP-2 ) = D * * Now find qmax. * QMAX = Z( 4*I0-PP-2 ) DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4 QMAX = MAX( QMAX, Z( I4 ) ) 70 CONTINUE * * Prepare for the next iteration on K. * PP = 1 - PP 80 CONTINUE * ITER = 2 NFAIL = 0 NDIV = 2*( N0-I0 ) * DO 140 IWHILA = 1, N + 1 IF( N0.LT.1 ) $ GO TO 150 * * While array unfinished do * * E(N0) holds the value of SIGMA when submatrix in I0:N0 * splits from the rest of the array, but is negated. * DESIG = ZERO IF( N0.EQ.N ) THEN SIGMA = ZERO ELSE SIGMA = -Z( 4*N0-1 ) END IF IF( SIGMA.LT.ZERO ) THEN INFO = 1 RETURN END IF * * Find last unreduced submatrix's top index I0, find QMAX and * EMIN. Find Gershgorin-type bound if Q's much greater than E's. * EMAX = ZERO IF( N0.GT.I0 ) THEN EMIN = ABS( Z( 4*N0-5 ) ) ELSE EMIN = ZERO END IF QMIN = Z( 4*N0-3 ) QMAX = QMIN DO 90 I4 = 4*N0, 8, -4 IF( Z( I4-5 ).LE.ZERO ) $ GO TO 100 IF( QMIN.GE.FOUR*EMAX ) THEN QMIN = MIN( QMIN, Z( I4-3 ) ) EMAX = MAX( EMAX, Z( I4-5 ) ) END IF QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) ) EMIN = MIN( EMIN, Z( I4-5 ) ) 90 CONTINUE I4 = 4 * 100 CONTINUE I0 = I4 / 4 * * Store EMIN for passing to DLASQ3. * Z( 4*N0-1 ) = EMIN * * Put -(initial shift) into DMIN. * DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) * * Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong. * PP = 0 * NBIG = 30*( N0-I0+1 ) DO 120 IWHILB = 1, NBIG IF( I0.GT.N0 ) $ GO TO 130 * * While submatrix unfinished take a good dqds step. * CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE ) * PP = 1 - PP * * When EMIN is very small check for splits. * IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN IF( Z( 4*N0 ).LE.TOL2*QMAX .OR. $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN SPLT = I0 - 1 QMAX = Z( 4*I0-3 ) EMIN = Z( 4*I0-1 ) OLDEMN = Z( 4*I0 ) DO 110 I4 = 4*I0, 4*( N0-3 ), 4 IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN Z( I4-1 ) = -SIGMA SPLT = I4 / 4 QMAX = ZERO EMIN = Z( I4+3 ) OLDEMN = Z( I4+4 ) ELSE QMAX = MAX( QMAX, Z( I4+1 ) ) EMIN = MIN( EMIN, Z( I4-1 ) ) OLDEMN = MIN( OLDEMN, Z( I4 ) ) END IF 110 CONTINUE Z( 4*N0-1 ) = EMIN Z( 4*N0 ) = OLDEMN I0 = SPLT + 1 END IF END IF * 120 CONTINUE * INFO = 2 RETURN * * end IWHILB * 130 CONTINUE * 140 CONTINUE * INFO = 3 RETURN * * end IWHILA * 150 CONTINUE * * Move q's to the front. * DO 160 K = 2, N Z( K ) = Z( 4*K-3 ) 160 CONTINUE * * Sort and compute sum of eigenvalues. * CALL DLASRT( 'D', N, Z, IINFO ) * E = ZERO DO 170 K = N, 1, -1 E = E + Z( K ) 170 CONTINUE * * Store trace, sum(eigenvalues) and information on performance. * Z( 2*N+1 ) = TRACE Z( 2*N+2 ) = E Z( 2*N+3 ) = DBLE( ITER ) Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 ) Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER ) RETURN * * End of DLASQ2 * END SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNML2 overwrites the general complex m-by-n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'C', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'C', * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(k)' . . . H(2)' H(1)' * * as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'C': apply Q' (Conjugate transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension * (LDA,M) if SIDE = 'L', * (LDA,N) if SIDE = 'R' * The i-th row must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGELQF in the first k rows of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,K). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGELQF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the m-by-n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACGV, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNML2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)' * IF( NOTRAN ) THEN TAUI = DCONJG( TAU( I ) ) ELSE TAUI = TAU( I ) END IF IF( I.LT.NQ ) $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) AII = A( I, I ) A( I, I ) = ONE CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII IF( I.LT.NQ ) $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) 10 CONTINUE RETURN * * End of ZUNML2 * END SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * May 17, 2000 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER I0, ITER, N0, NDIV, NFAIL, PP DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * Purpose * ======= * * DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. * In case of failure it changes shifts, and tries again until output * is positive. * * Arguments * ========= * * I0 (input) INTEGER * First index. * * N0 (input) INTEGER * Last index. * * Z (input) DOUBLE PRECISION array, dimension ( 4*N ) * Z holds the qd array. * * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * * DMIN (output) DOUBLE PRECISION * Minimum value of d. * * SIGMA (output) DOUBLE PRECISION * Sum of shifts used in current segment. * * DESIG (input/output) DOUBLE PRECISION * Lower order part of SIGMA * * QMAX (input) DOUBLE PRECISION * Maximum value of q. * * NFAIL (output) INTEGER * Number of times shift was too big. * * ITER (output) INTEGER * Number of iterations. * * NDIV (output) INTEGER * Number of divisions. * * TTYPE (output) INTEGER * Shift type. * * IEEE (input) LOGICAL * Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION CBIAS PARAMETER ( CBIAS = 1.50D0 ) DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) * .. * .. Local Scalars .. INTEGER IPN4, J4, N0IN, NN, TTYPE DOUBLE PRECISION DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T, $ TAU, TEMP, TOL, TOL2 * .. * .. External Subroutines .. EXTERNAL DLASQ4, DLASQ5, DLASQ6 * .. * .. External Function .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MIN, SQRT * .. * .. Save statement .. SAVE TTYPE SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU * .. * .. Data statement .. DATA TTYPE / 0 / DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /, $ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO / * .. * .. Executable Statements .. * N0IN = N0 EPS = DLAMCH( 'Precision' ) SAFMIN = DLAMCH( 'Safe minimum' ) TOL = EPS*HUNDRD TOL2 = TOL**2 * * Check for deflation. * 10 CONTINUE * IF( N0.LT.I0 ) $ RETURN IF( N0.EQ.I0 ) $ GO TO 20 NN = 4*N0 + PP IF( N0.EQ.( I0+1 ) ) $ GO TO 40 * * Check whether E(N0-1) is negligible, 1 eigenvalue. * IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) $ GO TO 30 * 20 CONTINUE * Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA N0 = N0 - 1 GO TO 10 * * Check whether E(N0-2) is negligible, 2 eigenvalues. * 30 CONTINUE * IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) $ GO TO 50 * 40 CONTINUE * IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN S = Z( NN-3 ) Z( NN-3 ) = Z( NN-7 ) Z( NN-7 ) = S END IF IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) S = Z( NN-3 )*( Z( NN-5 ) / T ) IF( S.LE.T ) THEN S = Z( NN-3 )*( Z( NN-5 ) / $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) ELSE S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) END IF T = Z( NN-7 ) + ( S+Z( NN-5 ) ) Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) Z( NN-7 ) = T END IF Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA N0 = N0 - 2 GO TO 10 * 50 CONTINUE * * Reverse the qd-array, if warranted. * IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN IPN4 = 4*( I0+N0 ) DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 TEMP = Z( J4-3 ) Z( J4-3 ) = Z( IPN4-J4-3 ) Z( IPN4-J4-3 ) = TEMP TEMP = Z( J4-2 ) Z( J4-2 ) = Z( IPN4-J4-2 ) Z( IPN4-J4-2 ) = TEMP TEMP = Z( J4-1 ) Z( J4-1 ) = Z( IPN4-J4-5 ) Z( IPN4-J4-5 ) = TEMP TEMP = Z( J4 ) Z( J4 ) = Z( IPN4-J4-4 ) Z( IPN4-J4-4 ) = TEMP 60 CONTINUE IF( N0-I0.LE.4 ) THEN Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) Z( 4*N0-PP ) = Z( 4*I0-PP ) END IF DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), $ Z( 4*I0+PP+3 ) ) Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), $ Z( 4*I0-PP+4 ) ) QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) DMIN = -ZERO END IF END IF * 70 CONTINUE * IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN * * Choose a shift. * CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, $ DN2, TAU, TTYPE ) * * Call dqds until DMIN > 0. * 80 CONTINUE * CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, IEEE ) * NDIV = NDIV + ( N0-I0+2 ) ITER = ITER + 1 * * Check status. * IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN * * Success. * GO TO 100 * ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. $ ABS( DN ).LT.TOL*SIGMA ) THEN * * Convergence hidden by negative DN. * Z( 4*( N0-1 )-PP+2 ) = ZERO DMIN = ZERO GO TO 100 ELSE IF( DMIN.LT.ZERO ) THEN * * TAU too big. Select new TAU and try again. * NFAIL = NFAIL + 1 IF( TTYPE.LT.-22 ) THEN * * Failed twice. Play it safe. * TAU = ZERO ELSE IF( DMIN1.GT.ZERO ) THEN * * Late failure. Gives excellent shift. * TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) TTYPE = TTYPE - 11 ELSE * * Early failure. Divide by 4. * TAU = QURTR*TAU TTYPE = TTYPE - 12 END IF GO TO 80 ELSE IF( DMIN.NE.DMIN ) THEN * * NaN. * TAU = ZERO GO TO 80 ELSE * * Possible underflow. Play it safe. * GO TO 90 END IF END IF * * Risk of underflow. * 90 CONTINUE CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) NDIV = NDIV + ( N0-I0+2 ) ITER = ITER + 1 TAU = ZERO * 100 CONTINUE IF( TAU.LT.SIGMA ) THEN DESIG = DESIG + TAU T = SIGMA + DESIG DESIG = DESIG - ( T-SIGMA ) ELSE T = SIGMA + TAU DESIG = SIGMA - ( T-TAU ) + DESIG END IF SIGMA = T * RETURN * * End of DLASQ3 * END SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, $ DN1, DN2, TAU, TTYPE ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1999 * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * Purpose * ======= * * DLASQ4 computes an approximation TAU to the smallest eigenvalue * using values of d from the previous transform. * * I0 (input) INTEGER * First index. * * N0 (input) INTEGER * Last index. * * Z (input) DOUBLE PRECISION array, dimension ( 4*N ) * Z holds the qd array. * * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * * NOIN (input) INTEGER * The value of N0 at start of EIGTEST. * * DMIN (input) DOUBLE PRECISION * Minimum value of d. * * DMIN1 (input) DOUBLE PRECISION * Minimum value of d, excluding D( N0 ). * * DMIN2 (input) DOUBLE PRECISION * Minimum value of d, excluding D( N0 ) and D( N0-1 ). * * DN (input) DOUBLE PRECISION * d(N) * * DN1 (input) DOUBLE PRECISION * d(N-1) * * DN2 (input) DOUBLE PRECISION * d(N-2) * * TAU (output) DOUBLE PRECISION * This is the shift. * * TTYPE (output) INTEGER * Shift type. * * Further Details * =============== * CNST1 = 9/16 * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION CNST1, CNST2, CNST3 PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, $ CNST3 = 1.050D0 ) DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, $ TWO = 2.0D0, HUNDRD = 100.0D0 ) * .. * .. Local Scalars .. INTEGER I4, NN, NP DOUBLE PRECISION A2, B1, B2, G, GAM, GAP1, GAP2, S * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Save statement .. SAVE G * .. * .. Data statement .. DATA G / ZERO / * .. * .. Executable Statements .. * * A negative DMIN forces the shift to take that absolute value * TTYPE records the type of shift. * IF( DMIN.LE.ZERO ) THEN TAU = -DMIN TTYPE = -1 RETURN END IF * NN = 4*N0 + PP IF( N0IN.EQ.N0 ) THEN * * No eigenvalues deflated. * IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN * B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) A2 = Z( NN-7 ) + Z( NN-5 ) * * Cases 2 and 3. * IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN GAP2 = DMIN2 - A2 - DMIN2*QURTR IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN GAP1 = A2 - DN - ( B2 / GAP2 )*B2 ELSE GAP1 = A2 - DN - ( B1+B2 ) END IF IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) TTYPE = -2 ELSE S = ZERO IF( DN.GT.B1 ) $ S = DN - B1 IF( A2.GT.( B1+B2 ) ) $ S = MIN( S, A2-( B1+B2 ) ) S = MAX( S, THIRD*DMIN ) TTYPE = -3 END IF ELSE * * Case 4. * TTYPE = -4 S = QURTR*DMIN IF( DMIN.EQ.DN ) THEN GAM = DN A2 = ZERO IF( Z( NN-5 ) .GT. Z( NN-7 ) ) $ RETURN B2 = Z( NN-5 ) / Z( NN-7 ) NP = NN - 9 ELSE NP = NN - 2*PP B2 = Z( NP-2 ) GAM = DN1 IF( Z( NP-4 ) .GT. Z( NP-2 ) ) $ RETURN A2 = Z( NP-4 ) / Z( NP-2 ) IF( Z( NN-9 ) .GT. Z( NN-11 ) ) $ RETURN B2 = Z( NN-9 ) / Z( NN-11 ) NP = NN - 13 END IF * * Approximate contribution to norm squared from I < NN-1. * A2 = A2 + B2 DO 10 I4 = NP, 4*I0 - 1 + PP, -4 IF( B2.EQ.ZERO ) $ GO TO 20 B1 = B2 IF( Z( I4 ) .GT. Z( I4-2 ) ) $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 20 10 CONTINUE 20 CONTINUE A2 = CNST3*A2 * * Rayleigh quotient residual bound. * IF( A2.LT.CNST1 ) $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) END IF ELSE IF( DMIN.EQ.DN2 ) THEN * * Case 5. * TTYPE = -5 S = QURTR*DMIN * * Compute contribution to norm squared from I > NN-2. * NP = NN - 2*PP B1 = Z( NP-2 ) B2 = Z( NP-6 ) GAM = DN2 IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) $ RETURN A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) * * Approximate contribution to norm squared from I < NN-2. * IF( N0-I0.GT.2 ) THEN B2 = Z( NN-13 ) / Z( NN-15 ) A2 = A2 + B2 DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 IF( B2.EQ.ZERO ) $ GO TO 40 B1 = B2 IF( Z( I4 ) .GT. Z( I4-2 ) ) $ RETURN B2 = B2*( Z( I4 ) / Z( I4-2 ) ) A2 = A2 + B2 IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) $ GO TO 40 30 CONTINUE 40 CONTINUE A2 = CNST3*A2 END IF * IF( A2.LT.CNST1 ) $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) ELSE * * Case 6, no information to guide us. * IF( TTYPE.EQ.-6 ) THEN G = G + THIRD*( ONE-G ) ELSE IF( TTYPE.EQ.-18 ) THEN G = QURTR*THIRD ELSE G = QURTR END IF S = G*DMIN TTYPE = -6 END IF * ELSE IF( N0IN.EQ.( N0+1 ) ) THEN * * One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. * IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN * * Cases 7 and 8. * TTYPE = -7 S = THIRD*DMIN1 IF( Z( NN-5 ).GT.Z( NN-7 ) ) $ RETURN B1 = Z( NN-5 ) / Z( NN-7 ) B2 = B1 IF( B2.EQ.ZERO ) $ GO TO 60 DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 A2 = B1 IF( Z( I4 ).GT.Z( I4-2 ) ) $ RETURN B1 = B1*( Z( I4 ) / Z( I4-2 ) ) B2 = B2 + B1 IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) $ GO TO 60 50 CONTINUE 60 CONTINUE B2 = SQRT( CNST3*B2 ) A2 = DMIN1 / ( ONE+B2**2 ) GAP2 = HALF*DMIN2 - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) TTYPE = -8 END IF ELSE * * Case 9. * S = QURTR*DMIN1 IF( DMIN1.EQ.DN1 ) $ S = HALF*DMIN1 TTYPE = -9 END IF * ELSE IF( N0IN.EQ.( N0+2 ) ) THEN * * Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. * * Cases 10 and 11. * IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN TTYPE = -10 S = THIRD*DMIN2 IF( Z( NN-5 ).GT.Z( NN-7 ) ) $ RETURN B1 = Z( NN-5 ) / Z( NN-7 ) B2 = B1 IF( B2.EQ.ZERO ) $ GO TO 80 DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 IF( Z( I4 ).GT.Z( I4-2 ) ) $ RETURN B1 = B1*( Z( I4 ) / Z( I4-2 ) ) B2 = B2 + B1 IF( HUNDRD*B1.LT.B2 ) $ GO TO 80 70 CONTINUE 80 CONTINUE B2 = SQRT( CNST3*B2 ) A2 = DMIN2 / ( ONE+B2**2 ) GAP2 = Z( NN-7 ) + Z( NN-9 ) - $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) ELSE S = MAX( S, A2*( ONE-CNST2*B2 ) ) END IF ELSE S = QURTR*DMIN2 TTYPE = -11 END IF ELSE IF( N0IN.GT.( N0+2 ) ) THEN * * Case 12, more than two eigenvalues deflated. No information. * S = ZERO TTYPE = -12 END IF * TAU = S RETURN * * End of DLASQ4 * END SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2, IEEE ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * May 17, 2000 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER I0, N0, PP DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * Purpose * ======= * * DLASQ5 computes one dqds transform in ping-pong form, one * version for IEEE machines another for non IEEE machines. * * Arguments * ========= * * I0 (input) INTEGER * First index. * * N0 (input) INTEGER * Last index. * * Z (input) DOUBLE PRECISION array, dimension ( 4*N ) * Z holds the qd array. EMIN is stored in Z(4*N0) to avoid * an extra argument. * * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * * TAU (input) DOUBLE PRECISION * This is the shift. * * DMIN (output) DOUBLE PRECISION * Minimum value of d. * * DMIN1 (output) DOUBLE PRECISION * Minimum value of d, excluding D( N0 ). * * DMIN2 (output) DOUBLE PRECISION * Minimum value of d, excluding D( N0 ) and D( N0-1 ). * * DN (output) DOUBLE PRECISION * d(N0), the last value of d. * * DNM1 (output) DOUBLE PRECISION * d(N0-1). * * DNM2 (output) DOUBLE PRECISION * d(N0-2). * * IEEE (input) LOGICAL * Flag for IEEE or non IEEE arithmetic. * * ===================================================================== * * .. Parameter .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. INTEGER J4, J4P2 DOUBLE PRECISION D, EMIN, TEMP * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( ( N0-I0-1 ).LE.0 ) $ RETURN * J4 = 4*I0 + PP - 3 EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) * IF( IEEE ) THEN * * Code for IEEE arithmetic. * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) Z( J4 ) = Z( J4-1 )*TEMP EMIN = MIN( Z( J4 ), EMIN ) 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) Z( J4-1 ) = Z( J4 )*TEMP EMIN = MIN( Z( J4-1 ), EMIN ) 20 CONTINUE END IF * * Unroll last two steps. * DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM2 + Z( J4P2 ) Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DNM1 ) * DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU DMIN = MIN( DMIN, DN ) * ELSE * * Code for non IEEE arithmetic. * IF( PP.EQ.0 ) THEN DO 30 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4 ) ) 30 CONTINUE ELSE DO 40 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4-1 ) ) 40 CONTINUE END IF * * Unroll last two steps. * DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM2 + Z( J4P2 ) IF( DNM2.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DNM1 ) * DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) IF( DNM1.LT.ZERO ) THEN RETURN ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU END IF DMIN = MIN( DMIN, DN ) * END IF * Z( J4+2 ) = DN Z( 4*N0-PP ) = EMIN RETURN * * End of DLASQ5 * END SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1999 * * .. Scalar Arguments .. INTEGER I0, N0, PP DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) * .. * * Purpose * ======= * * DLASQ6 computes one dqd (shift equal to zero) transform in * ping-pong form, with protection against underflow and overflow. * * Arguments * ========= * * I0 (input) INTEGER * First index. * * N0 (input) INTEGER * Last index. * * Z (input) DOUBLE PRECISION array, dimension ( 4*N ) * Z holds the qd array. EMIN is stored in Z(4*N0) to avoid * an extra argument. * * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * * DMIN (output) DOUBLE PRECISION * Minimum value of d. * * DMIN1 (output) DOUBLE PRECISION * Minimum value of d, excluding D( N0 ). * * DMIN2 (output) DOUBLE PRECISION * Minimum value of d, excluding D( N0 ) and D( N0-1 ). * * DN (output) DOUBLE PRECISION * d(N0), the last value of d. * * DNM1 (output) DOUBLE PRECISION * d(N0-1). * * DNM2 (output) DOUBLE PRECISION * d(N0-2). * * ===================================================================== * * .. Parameter .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. INTEGER J4, J4P2 DOUBLE PRECISION D, EMIN, SAFMIN, TEMP * .. * .. External Function .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( ( N0-I0-1 ).LE.0 ) $ RETURN * SAFMIN = DLAMCH( 'Safe minimum' ) J4 = 4*I0 + PP - 3 EMIN = Z( J4+4 ) D = Z( J4 ) DMIN = D * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-2 ) = D + Z( J4-1 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO D = Z( J4+1 ) DMIN = D EMIN = ZERO ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND. $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN TEMP = Z( J4+1 ) / Z( J4-2 ) Z( J4 ) = Z( J4-1 )*TEMP D = D*TEMP ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4 ) ) 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 Z( J4-3 ) = D + Z( J4 ) IF( Z( J4-3 ).EQ.ZERO ) THEN Z( J4-1 ) = ZERO D = Z( J4+2 ) DMIN = D EMIN = ZERO ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND. $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN TEMP = Z( J4+2 ) / Z( J4-3 ) Z( J4-1 ) = Z( J4 )*TEMP D = D*TEMP ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) END IF DMIN = MIN( DMIN, D ) EMIN = MIN( EMIN, Z( J4-1 ) ) 20 CONTINUE END IF * * Unroll last two steps. * DNM2 = D DMIN2 = DMIN J4 = 4*( N0-2 ) - PP J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM2 + Z( J4P2 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO DNM1 = Z( J4P2+2 ) DMIN = DNM1 EMIN = ZERO ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN TEMP = Z( J4P2+2 ) / Z( J4-2 ) Z( J4 ) = Z( J4P2 )*TEMP DNM1 = DNM2*TEMP ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) END IF DMIN = MIN( DMIN, DNM1 ) * DMIN1 = DMIN J4 = J4 + 4 J4P2 = J4 + 2*PP - 1 Z( J4-2 ) = DNM1 + Z( J4P2 ) IF( Z( J4-2 ).EQ.ZERO ) THEN Z( J4 ) = ZERO DN = Z( J4P2+2 ) DMIN = DN EMIN = ZERO ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND. $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN TEMP = Z( J4P2+2 ) / Z( J4-2 ) Z( J4 ) = Z( J4P2 )*TEMP DN = DNM1*TEMP ELSE Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) ) DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) END IF DMIN = MIN( DMIN, DN ) * Z( J4+2 ) = DN Z( 4*N0-PP ) = EMIN RETURN * * End of DLASQ6 * END SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, IWORK, IFAIL, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), $ Z( LDZ, * ) * .. * * Purpose * ======= * * DSYGVX computes selected eigenvalues, and optionally, eigenvectors * of a real generalized symmetric-definite eigenproblem, of the form * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A * and B are assumed to be symmetric and B is also positive definite. * Eigenvalues and eigenvectors can be selected by specifying either a * range of values or a range of indices for the desired eigenvalues. * * Arguments * ========= * * ITYPE (input) INTEGER * Specifies the problem type to be solved: * = 1: A*x = (lambda)*B*x * = 2: A*B*x = (lambda)*x * = 3: B*A*x = (lambda)*x * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * RANGE (input) CHARACTER*1 * = 'A': all eigenvalues will be found. * = 'V': all eigenvalues in the half-open interval (VL,VU] * will be found. * = 'I': the IL-th through IU-th eigenvalues will be found. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A and B are stored; * = 'L': Lower triangle of A and B are stored. * * N (input) INTEGER * The order of the matrix pencil (A,B). N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) * On entry, the symmetric matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * * On exit, the lower triangle (if UPLO='L') or the upper * triangle (if UPLO='U') of A, including the diagonal, is * destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * B (input/output) DOUBLE PRECISION array, dimension (LDA, N) * On entry, the symmetric matrix B. If UPLO = 'U', the * leading N-by-N upper triangular part of B contains the * upper triangular part of the matrix B. If UPLO = 'L', * the leading N-by-N lower triangular part of B contains * the lower triangular part of the matrix B. * * On exit, if INFO <= N, the part of B containing the matrix is * overwritten by the triangular factor U or L from the Cholesky * factorization B = U**T*U or B = L*L**T. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * VL (input) DOUBLE PRECISION * VU (input) DOUBLE PRECISION * If RANGE='V', the lower and upper bounds of the interval to * be searched for eigenvalues. VL < VU. * Not referenced if RANGE = 'A' or 'I'. * * IL (input) INTEGER * IU (input) INTEGER * If RANGE='I', the indices (in ascending order) of the * smallest and largest eigenvalues to be returned. * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. * Not referenced if RANGE = 'A' or 'V'. * * ABSTOL (input) DOUBLE PRECISION * The absolute error tolerance for the eigenvalues. * An approximate eigenvalue is accepted as converged * when it is determined to lie in an interval [a,b] * of width less than or equal to * * ABSTOL + EPS * max( |a|,|b| ) , * * where EPS is the machine precision. If ABSTOL is less than * or equal to zero, then EPS*|T| will be used in its place, * where |T| is the 1-norm of the tridiagonal matrix obtained * by reducing A to tridiagonal form. * * Eigenvalues will be computed most accurately when ABSTOL is * set to twice the underflow threshold 2*DLAMCH('S'), not zero. * If this routine returns with INFO>0, indicating that some * eigenvectors did not converge, try setting ABSTOL to * 2*DLAMCH('S'). * * M (output) INTEGER * The total number of eigenvalues found. 0 <= M <= N. * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. * * W (output) DOUBLE PRECISION array, dimension (N) * On normal exit, the first M elements contain the selected * eigenvalues in ascending order. * * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) * If JOBZ = 'N', then Z is not referenced. * If JOBZ = 'V', then if INFO = 0, the first M columns of Z * contain the orthonormal eigenvectors of the matrix A * corresponding to the selected eigenvalues, with the i-th * column of Z holding the eigenvector associated with W(i). * The eigenvectors are normalized as follows: * if ITYPE = 1 or 2, Z**T*B*Z = I; * if ITYPE = 3, Z**T*inv(B)*Z = I. * * If an eigenvector fails to converge, then that column of Z * contains the latest approximation to the eigenvector, and the * index of the eigenvector is returned in IFAIL. * Note: the user must ensure that at least max(1,M) columns are * supplied in the array Z; if RANGE = 'V', the exact value of M * is not known in advance and an upper bound must be used. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * JOBZ = 'V', LDZ >= max(1,N). * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,8*N). * For optimal efficiency, LWORK >= (NB+3)*N, * where NB is the blocksize for DSYTRD returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * IWORK (workspace) INTEGER array, dimension (5*N) * * IFAIL (output) INTEGER array, dimension (N) * If JOBZ = 'V', then if INFO = 0, the first M elements of * IFAIL are zero. If INFO > 0, then IFAIL contains the * indices of the eigenvectors that failed to converge. * If JOBZ = 'N', then IFAIL is not referenced. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: DPOTRF or DSYEVX returned an error code: * <= N: if INFO = i, DSYEVX failed to converge; * i eigenvectors failed to converge. Their indices * are stored in array IFAIL. * > N: if INFO = N + i, for 1 <= i <= N, then the leading * minor of order i of B is not positive definite. * The factorization of B could not be completed and * no eigenvalues or eigenvectors were computed. * * Further Details * =============== * * Based on contributions by * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ CHARACTER TRANS INTEGER LOPT, LWKOPT, NB * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( ITYPE.LT.0 .OR. ITYPE.GT.3 ) THEN INFO = -1 ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -3 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( VALEIG .AND. N.GT.0 ) THEN IF( VU.LE.VL ) $ INFO = -11 ELSE IF( INDEIG .AND. IL.LT.1 ) THEN INFO = -12 ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN INFO = -13 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -18 ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN INFO = -20 END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) LWKOPT = ( NB+3 )*N WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYGVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * * Form a Cholesky factorization of B. * CALL DPOTRF( UPLO, N, B, LDB, INFO ) IF( INFO.NE.0 ) THEN INFO = N + INFO RETURN END IF * * Transform problem to standard eigenvalue problem and solve. * CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) LOPT = WORK( 1 ) * IF( WANTZ ) THEN * * Backtransform eigenvectors to the original problem. * IF( INFO.GT.0 ) $ M = INFO - 1 IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN * * For A*x=(lambda)*B*x and A*B*x=(lambda)*x; * backtransform eigenvectors: x = inv(L)'*y or inv(U)*y * IF( UPPER ) THEN TRANS = 'N' ELSE TRANS = 'T' END IF * CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, $ LDB, Z, LDZ ) * ELSE IF( ITYPE.EQ.3 ) THEN * * For B*A*x=(lambda)*x; * backtransform eigenvectors: x = L*y or U'*y * IF( UPPER ) THEN TRANS = 'T' ELSE TRANS = 'N' END IF * CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B, $ LDB, Z, LDZ ) END IF END IF * * Set WORK(1) to optimal workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of DSYGVX * END SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, $ IFAIL, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N DOUBLE PRECISION ABSTOL, VL, VU * .. * .. Array Arguments .. INTEGER IFAIL( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * DSYEVX computes selected eigenvalues and, optionally, eigenvectors * of a real symmetric matrix A. Eigenvalues and eigenvectors can be * selected by specifying either a range of values or a range of indices * for the desired eigenvalues. * * Arguments * ========= * * JOBZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only; * = 'V': Compute eigenvalues and eigenvectors. * * RANGE (input) CHARACTER*1 * = 'A': all eigenvalues will be found. * = 'V': all eigenvalues in the half-open interval (VL,VU] * will be found. * = 'I': the IL-th through IU-th eigenvalues will be found. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A is stored; * = 'L': Lower triangle of A is stored. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA, N) * On entry, the symmetric matrix A. If UPLO = 'U', the * leading N-by-N upper triangular part of A contains the * upper triangular part of the matrix A. If UPLO = 'L', * the leading N-by-N lower triangular part of A contains * the lower triangular part of the matrix A. * On exit, the lower triangle (if UPLO='L') or the upper * triangle (if UPLO='U') of A, including the diagonal, is * destroyed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * VL (input) DOUBLE PRECISION * VU (input) DOUBLE PRECISION * If RANGE='V', the lower and upper bounds of the interval to * be searched for eigenvalues. VL < VU. * Not referenced if RANGE = 'A' or 'I'. * * IL (input) INTEGER * IU (input) INTEGER * If RANGE='I', the indices (in ascending order) of the * smallest and largest eigenvalues to be returned. * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. * Not referenced if RANGE = 'A' or 'V'. * * ABSTOL (input) DOUBLE PRECISION * The absolute error tolerance for the eigenvalues. * An approximate eigenvalue is accepted as converged * when it is determined to lie in an interval [a,b] * of width less than or equal to * * ABSTOL + EPS * max( |a|,|b| ) , * * where EPS is the machine precision. If ABSTOL is less than * or equal to zero, then EPS*|T| will be used in its place, * where |T| is the 1-norm of the tridiagonal matrix obtained * by reducing A to tridiagonal form. * * Eigenvalues will be computed most accurately when ABSTOL is * set to twice the underflow threshold 2*DLAMCH('S'), not zero. * If this routine returns with INFO>0, indicating that some * eigenvectors did not converge, try setting ABSTOL to * 2*DLAMCH('S'). * * See "Computing Small Singular Values of Bidiagonal Matrices * with Guaranteed High Relative Accuracy," by Demmel and * Kahan, LAPACK Working Note #3. * * M (output) INTEGER * The total number of eigenvalues found. 0 <= M <= N. * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. * * W (output) DOUBLE PRECISION array, dimension (N) * On normal exit, the first M elements contain the selected * eigenvalues in ascending order. * * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) * If JOBZ = 'V', then if INFO = 0, the first M columns of Z * contain the orthonormal eigenvectors of the matrix A * corresponding to the selected eigenvalues, with the i-th * column of Z holding the eigenvector associated with W(i). * If an eigenvector fails to converge, then that column of Z * contains the latest approximation to the eigenvector, and the * index of the eigenvector is returned in IFAIL. * If JOBZ = 'N', then Z is not referenced. * Note: the user must ensure that at least max(1,M) columns are * supplied in the array Z; if RANGE = 'V', the exact value of M * is not known in advance and an upper bound must be used. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * JOBZ = 'V', LDZ >= max(1,N). * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The length of the array WORK. LWORK >= max(1,8*N). * For optimal efficiency, LWORK >= (NB+3)*N, * where NB is the max of the blocksize for DSYTRD and DORMTR * returned by ILAENV. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * IWORK (workspace) INTEGER array, dimension (5*N) * * IFAIL (output) INTEGER array, dimension (N) * If JOBZ = 'V', then if INFO = 0, the first M elements of * IFAIL are zero. If INFO > 0, then IFAIL contains the * indices of the eigenvectors that failed to converge. * If JOBZ = 'N', then IFAIL is not referenced. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, then i eigenvectors failed to converge. * Their indices are stored in array IFAIL. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ CHARACTER ORDER INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LLWRKN, LOPT, LWKOPT, NB, $ NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, $ SIGMA, SMLNUM, TMP1, VLL, VUU * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * LOWER = LSAME( UPLO, 'L' ) WANTZ = LSAME( JOBZ, 'V' ) ALLEIG = LSAME( RANGE, 'A' ) VALEIG = LSAME( RANGE, 'V' ) INDEIG = LSAME( RANGE, 'I' ) LQUERY = ( LWORK.EQ.-1 ) * INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( VALEIG ) THEN IF( N.GT.0 .AND. VU.LE.VL ) $ INFO = -8 ELSE IF( INDEIG ) THEN IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN INFO = -10 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -15 ELSE IF( LWORK.LT.MAX( 1, 8*N ) .AND. .NOT.LQUERY ) THEN INFO = -17 END IF END IF * IF( INFO.EQ.0 ) THEN NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) LWKOPT = ( NB+3 )*N WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSYEVX', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * M = 0 IF( N.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( N.EQ.1 ) THEN WORK( 1 ) = 7 IF( ALLEIG .OR. INDEIG ) THEN M = 1 W( 1 ) = A( 1, 1 ) ELSE IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN M = 1 W( 1 ) = A( 1, 1 ) END IF END IF IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) * * Scale matrix to allowable range, if necessary. * ISCALE = 0 ABSTLL = ABSTOL VLL = VL VUU = VU ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN DO 10 J = 1, N CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) 10 CONTINUE ELSE DO 20 J = 1, N CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) 20 CONTINUE END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA IF( VALEIG ) THEN VLL = VL*SIGMA VUU = VU*SIGMA END IF END IF * * Call DSYTRD to reduce symmetric matrix to tridiagonal form. * INDTAU = 1 INDE = INDTAU + N INDD = INDE + N INDWRK = INDD + N LLWORK = LWORK - INDWRK + 1 CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) LOPT = 3*N + WORK( INDWRK ) * * If all eigenvalues are desired and ABSTOL is less than or equal to * zero, then call DSTERF or DORGTR and SSTEQR. If this fails for * some eigenvalue, then try DSTEBZ. * IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. $ ( ABSTOL.LE.ZERO ) ) THEN CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) INDEE = INDWRK + 2*N IF( .NOT.WANTZ ) THEN CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTERF( N, W, WORK( INDEE ), INFO ) ELSE CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), $ WORK( INDWRK ), LLWORK, IINFO ) CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, $ WORK( INDWRK ), INFO ) IF( INFO.EQ.0 ) THEN DO 30 I = 1, N IFAIL( I ) = 0 30 CONTINUE END IF END IF IF( INFO.EQ.0 ) THEN M = N GO TO 40 END IF INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. * IF( WANTZ ) THEN ORDER = 'B' ELSE ORDER = 'E' END IF INDIBL = 1 INDISP = INDIBL + N INDIWO = INDISP + N CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) * * Apply orthogonal matrix used in reduction to tridiagonal * form to eigenvectors returned by DSTEIN. * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = M ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF * * If eigenvalues are not in order, then sort them, along with * eigenvectors. * IF( WANTZ ) THEN DO 60 J = 1, M - 1 I = 0 TMP1 = W( J ) DO 50 JJ = J + 1, M IF( W( JJ ).LT.TMP1 ) THEN I = JJ TMP1 = W( JJ ) END IF 50 CONTINUE * IF( I.NE.0 ) THEN ITMP1 = IWORK( INDIBL+I-1 ) W( I ) = W( J ) IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) W( J ) = TMP1 IWORK( INDIBL+J-1 ) = ITMP1 CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) IF( INFO.NE.0 ) THEN ITMP1 = IFAIL( I ) IFAIL( I ) = IFAIL( J ) IFAIL( J ) = ITMP1 END IF END IF 60 CONTINUE END IF * * Set WORK(1) to optimal workspace size. * WORK( 1 ) = LWKOPT * RETURN * * End of DSYEVX * END SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, LDB, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DLACPY copies all or part of a two-dimensional matrix A to another * matrix B. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be copied to B. * = 'U': Upper triangular part * = 'L': Lower triangular part * Otherwise: All of the matrix A * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The m by n matrix A. If UPLO = 'U', only the upper triangle * or trapezoid is accessed; if UPLO = 'L', only the lower * triangle or trapezoid is accessed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (output) DOUBLE PRECISION array, dimension (LDB,N) * On exit, B = A in the locations specified by UPLO. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF RETURN * * End of DLACPY * END SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INFO, LDZ, M, N * .. * .. Array Arguments .. INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), $ IWORK( * ) DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * DSTEIN computes the eigenvectors of a real symmetric tridiagonal * matrix T corresponding to specified eigenvalues, using inverse * iteration. * * The maximum number of iterations allowed for each eigenvector is * specified by an internal parameter MAXITS (currently set to 5). * * Arguments * ========= * * N (input) INTEGER * The order of the matrix. N >= 0. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the tridiagonal matrix T. * * E (input) DOUBLE PRECISION array, dimension (N) * The (n-1) subdiagonal elements of the tridiagonal matrix * T, in elements 1 to N-1. E(N) need not be set. * * M (input) INTEGER * The number of eigenvectors to be found. 0 <= M <= N. * * W (input) DOUBLE PRECISION array, dimension (N) * The first M elements of W contain the eigenvalues for * which eigenvectors are to be computed. The eigenvalues * should be grouped by split-off block and ordered from * smallest to largest within the block. ( The output array * W from DSTEBZ with ORDER = 'B' is expected here. ) * * IBLOCK (input) INTEGER array, dimension (N) * The submatrix indices associated with the corresponding * eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to * the first submatrix from the top, =2 if W(i) belongs to * the second submatrix, etc. ( The output array IBLOCK * from DSTEBZ is expected here. ) * * ISPLIT (input) INTEGER array, dimension (N) * The splitting points, at which T breaks up into submatrices. * The first submatrix consists of rows/columns 1 to * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 * through ISPLIT( 2 ), etc. * ( The output array ISPLIT from DSTEBZ is expected here. ) * * Z (output) DOUBLE PRECISION array, dimension (LDZ, M) * The computed eigenvectors. The eigenvector associated * with the eigenvalue W(i) is stored in the i-th column of * Z. Any vector which fails to converge is set to its current * iterate after MAXITS iterations. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * * WORK (workspace) DOUBLE PRECISION array, dimension (5*N) * * IWORK (workspace) INTEGER array, dimension (N) * * IFAIL (output) INTEGER array, dimension (M) * On normal exit, all elements of IFAIL are zero. * If one or more eigenvectors fail to converge after * MAXITS iterations, then their indices are stored in * array IFAIL. * * INFO (output) INTEGER * = 0: successful exit. * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, then i eigenvectors failed to converge * in MAXITS iterations. Their indices are stored in * array IFAIL. * * Internal Parameters * =================== * * MAXITS INTEGER, default = 5 * The maximum number of iterations performed. * * EXTRA INTEGER, default = 2 * The number of iterations performed after norm growth * criterion is satisfied, should be at least 1. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) INTEGER MAXITS, EXTRA PARAMETER ( MAXITS = 5, EXTRA = 2 ) * .. * .. Local Scalars .. INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, $ JBLK, JMAX, NBLK, NRMCHK DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, $ SCL, SEP, TOL, XJ, XJM, ZTR * .. * .. Local Arrays .. INTEGER ISEED( 4 ) * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2 EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2 * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 DO 10 I = 1, M IFAIL( I ) = 0 10 CONTINUE * IF( N.LT.0 ) THEN INFO = -1 ELSE IF( M.LT.0 .OR. M.GT.N ) THEN INFO = -4 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE DO 20 J = 2, M IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN INFO = -6 GO TO 30 END IF IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) $ THEN INFO = -5 GO TO 30 END IF 20 CONTINUE 30 CONTINUE END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEIN', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) THEN RETURN ELSE IF( N.EQ.1 ) THEN Z( 1, 1 ) = ONE RETURN END IF * * Get machine constants. * EPS = DLAMCH( 'Precision' ) * * Initialize seed for random number generator DLARNV. * DO 40 I = 1, 4 ISEED( I ) = 1 40 CONTINUE * * Initialize pointers. * INDRV1 = 0 INDRV2 = INDRV1 + N INDRV3 = INDRV2 + N INDRV4 = INDRV3 + N INDRV5 = INDRV4 + N * * Compute eigenvectors of matrix blocks. * J1 = 1 DO 160 NBLK = 1, IBLOCK( M ) * * Find starting and ending indices of block nblk. * IF( NBLK.EQ.1 ) THEN B1 = 1 ELSE B1 = ISPLIT( NBLK-1 ) + 1 END IF BN = ISPLIT( NBLK ) BLKSIZ = BN - B1 + 1 IF( BLKSIZ.EQ.1 ) $ GO TO 60 GPIND = B1 * * Compute reorthogonalization criterion and stopping criterion. * ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) DO 50 I = B1 + 1, BN - 1 ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ $ ABS( E( I ) ) ) 50 CONTINUE ORTOL = ODM3*ONENRM * DTPCRT = SQRT( ODM1 / BLKSIZ ) * * Loop through eigenvalues of block nblk. * 60 CONTINUE JBLK = 0 DO 150 J = J1, M IF( IBLOCK( J ).NE.NBLK ) THEN J1 = J GO TO 160 END IF JBLK = JBLK + 1 XJ = W( J ) * * Skip all the work if the block size is one. * IF( BLKSIZ.EQ.1 ) THEN WORK( INDRV1+1 ) = ONE GO TO 120 END IF * * If eigenvalues j and j-1 are too close, add a relatively * small perturbation. * IF( JBLK.GT.1 ) THEN EPS1 = ABS( EPS*XJ ) PERTOL = TEN*EPS1 SEP = XJ - XJM IF( SEP.LT.PERTOL ) $ XJ = XJM + PERTOL END IF * ITS = 0 NRMCHK = 0 * * Get random starting vector. * CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) * * Copy the matrix T so it won't be destroyed in factorization. * CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) * * Compute LU factors with partial pivoting ( PT = LU ) * TOL = ZERO CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, $ IINFO ) * * Update iteration count. * 70 CONTINUE ITS = ITS + 1 IF( ITS.GT.MAXITS ) $ GO TO 100 * * Normalize and scale the righthand side vector Pb. * SCL = BLKSIZ*ONENRM*MAX( EPS, $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / $ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 ) CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) * * Solve the system LU = Pb. * CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, $ WORK( INDRV1+1 ), TOL, IINFO ) * * Reorthogonalize by modified Gram-Schmidt if eigenvalues are * close enough. * IF( JBLK.EQ.1 ) $ GO TO 90 IF( ABS( XJ-XJM ).GT.ORTOL ) $ GPIND = J IF( GPIND.NE.J ) THEN DO 80 I = GPIND, J - 1 ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), $ 1 ) CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, $ WORK( INDRV1+1 ), 1 ) 80 CONTINUE END IF * * Check the infinity norm of the iterate. * 90 CONTINUE JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) NRM = ABS( WORK( INDRV1+JMAX ) ) * * Continue for additional iterations after norm reaches * stopping criterion. * IF( NRM.LT.DTPCRT ) $ GO TO 70 NRMCHK = NRMCHK + 1 IF( NRMCHK.LT.EXTRA+1 ) $ GO TO 70 * GO TO 110 * * If stopping criterion was not satisfied, update info and * store eigenvector number in array ifail. * 100 CONTINUE INFO = INFO + 1 IFAIL( INFO ) = J * * Accept iterate as jth eigenvector. * 110 CONTINUE SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) IF( WORK( INDRV1+JMAX ).LT.ZERO ) $ SCL = -SCL CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) 120 CONTINUE DO 130 I = 1, N Z( I, J ) = ZERO 130 CONTINUE DO 140 I = 1, BLKSIZ Z( B1+I-1, J ) = WORK( INDRV1+I ) 140 CONTINUE * * Save the shift to check eigenvalue spacing at next * iteration. * XJM = XJ * 150 CONTINUE 160 CONTINUE * RETURN * * End of DSTEIN * END SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO INTEGER INFO, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORMTR overwrites the general real M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'T': Q**T * C C * Q**T * * where Q is a real orthogonal matrix of order nq, with nq = m if * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of * nq-1 elementary reflectors, as returned by DSYTRD: * * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); * * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**T from the Left; * = 'R': apply Q or Q**T from the Right. * * UPLO (input) CHARACTER*1 * = 'U': Upper triangle of A contains elementary reflectors * from DSYTRD; * = 'L': Lower triangle of A contains elementary reflectors * from DSYTRD. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'T': Transpose, apply Q**T. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * A (input) DOUBLE PRECISION array, dimension * (LDA,M) if SIDE = 'L' * (LDA,N) if SIDE = 'R' * The vectors which define the elementary reflectors, as * returned by DSYTRD. * * LDA (input) INTEGER * The leading dimension of the array A. * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. * * TAU (input) DOUBLE PRECISION array, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DSYTRD. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL LEFT, LQUERY, UPPER INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DORMQL, DORMQR, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) $ THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN IF( UPPER ) THEN IF( LEFT ) THEN NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF ELSE IF( LEFT ) THEN NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, $ -1 ) ELSE NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, $ -1 ) END IF END IF LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMTR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN WORK( 1 ) = 1 RETURN END IF * IF( LEFT ) THEN MI = M - 1 NI = N ELSE MI = M NI = N - 1 END IF * IF( UPPER ) THEN * * Q was determined by a call to DSYTRD with UPLO = 'U' * CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, $ LDC, WORK, LWORK, IINFO ) ELSE * * Q was determined by a call to DSYTRD with UPLO = 'L' * IF( LEFT ) THEN I1 = 2 I2 = 1 ELSE I1 = 1 I2 = 2 END IF CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMTR * END SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORMQR overwrites the general real M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'T': Q**T * C C * Q**T * * where Q is a real orthogonal matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**T from the Left; * = 'R': apply Q or Q**T from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'T': Transpose, apply Q**T. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * DGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. DOUBLE PRECISION T( LDT, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. NB may be at most NBMAX, where NBMAX * is used to define the local array T. * NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMQR', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IWS = NW*NB IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, $ -1 ) ) END IF ELSE IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i) H(i+1) . . . H(i+ib-1) * CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), $ LDA, TAU( I ), T, LDT ) IF( LEFT ) THEN * * H or H' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H or H' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H or H' * CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, $ WORK, LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMQR * END SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, LWORK, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORMQL overwrites the general real M-by-N matrix C with * * SIDE = 'L' SIDE = 'R' * TRANS = 'N': Q * C C * Q * TRANS = 'T': Q**T * C C * Q**T * * where Q is a real orthogonal matrix defined as the product of k * elementary reflectors * * Q = H(k) . . . H(2) H(1) * * as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q**T from the Left; * = 'R': apply Q or Q**T from the Right. * * TRANS (input) CHARACTER*1 * = 'N': No transpose, apply Q; * = 'T': Transpose, apply Q**T. * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * DGEQLF in the last k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQLF. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. * * LWORK (input) INTEGER * The dimension of the array WORK. * If SIDE = 'L', LWORK >= max(1,N); * if SIDE = 'R', LWORK >= max(1,M). * For optimum performance LWORK >= N*NB if SIDE = 'L', and * LWORK >= M*NB if SIDE = 'R', where NB is the optimal * blocksize. * * If LWORK = -1, then a workspace query is assumed; the routine * only calculates the optimal size of the WORK array, returns * this value as the first entry of the WORK array, and no error * message related to LWORK is issued by XERBLA. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER NBMAX, LDT PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) * .. * .. Local Scalars .. LOGICAL LEFT, LQUERY, NOTRAN INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT, $ MI, NB, NBMIN, NI, NQ, NW * .. * .. Local Arrays .. DOUBLE PRECISION T( LDT, NBMAX ) * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV * .. * .. External Subroutines .. EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) LQUERY = ( LWORK.EQ.-1 ) * * NQ is the order of Q and NW is the minimum dimension of WORK * IF( LEFT ) THEN NQ = M NW = N ELSE NQ = N NW = M END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN INFO = -12 END IF * IF( INFO.EQ.0 ) THEN * * Determine the block size. NB may be at most NBMAX, where NBMAX * is used to define the local array T. * NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, K, $ -1 ) ) LWKOPT = MAX( 1, NW )*NB WORK( 1 ) = LWKOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORMQL', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN WORK( 1 ) = 1 RETURN END IF * NBMIN = 2 LDWORK = NW IF( NB.GT.1 .AND. NB.LT.K ) THEN IWS = NW*NB IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, $ -1 ) ) END IF ELSE IWS = NW END IF * IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN * * Use unblocked code * CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, $ IINFO ) ELSE * * Use blocked code * IF( ( LEFT .AND. NOTRAN ) .OR. $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN I1 = 1 I2 = K I3 = NB ELSE I1 = ( ( K-1 ) / NB )*NB + 1 I2 = 1 I3 = -NB END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IB = MIN( NB, K-I+1 ) * * Form the triangular factor of the block reflector * H = H(i+ib-1) . . . H(i+1) H(i) * CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB, $ A( 1, I ), LDA, TAU( I ), T, LDT ) IF( LEFT ) THEN * * H or H' is applied to C(1:m-k+i+ib-1,1:n) * MI = M - K + I + IB - 1 ELSE * * H or H' is applied to C(1:m,1:n-k+i+ib-1) * NI = N - K + I + IB - 1 END IF * * Apply H or H' * CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI, $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, $ LDWORK ) 10 CONTINUE END IF WORK( 1 ) = LWKOPT RETURN * * End of DORMQL * END SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORM2L overwrites the general real m by n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'T', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'T', * * where Q is a real orthogonal matrix defined as the product of k * elementary reflectors * * Q = H(k) . . . H(2) H(1) * * as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'T': apply Q' (Transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * DGEQLF in the last k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQLF. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORM2L', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N ELSE MI = M END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(1:m-k+i,1:n) * MI = M - K + I ELSE * * H(i) is applied to C(1:m,1:n-k+i) * NI = N - K + I END IF * * Apply H(i) * AII = A( NQ-K+I, I ) A( NQ-K+I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, $ WORK ) A( NQ-K+I, I ) = AII 10 CONTINUE RETURN * * End of DORM2L * END SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORM2R overwrites the general real m by n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'T', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'T', * * where Q is a real orthogonal matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'T': apply Q' (Transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * DGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of DORM2R * END SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK driver routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DGESV computes the solution to a real system of linear equations * A * X = B, * where A is an N-by-N matrix and X and B are N-by-NRHS matrices. * * The LU decomposition with partial pivoting and row interchanges is * used to factor A as * A = P * L * U, * where P is a permutation matrix, L is unit lower triangular, and U is * upper triangular. The factored form of A is then used to solve the * system of equations A * X = B. * * Arguments * ========= * * N (input) INTEGER * The number of linear equations, i.e., the order of the * matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On entry, the N-by-N coefficient matrix A. * On exit, the factors L and U from the factorization * A = P*L*U; the unit diagonal elements of L are not stored. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (output) INTEGER array, dimension (N) * The pivot indices that define the permutation matrix P; * row i of the matrix was interchanged with row IPIV(i). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the N-by-NRHS matrix of right hand side matrix B. * On exit, if INFO = 0, the N-by-NRHS solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, U(i,i) is exactly zero. The factorization * has been completed, but the factor U is exactly * singular, so the solution could not be computed. * * ===================================================================== * * .. External Subroutines .. EXTERNAL DGETRF, DGETRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGESV ', -INFO ) RETURN END IF * * Compute the LU factorization of A. * CALL DGETRF( N, N, A, LDA, IPIV, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, $ INFO ) END IF RETURN * * End of DGESV * END SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DGETRS solves a system of linear equations * A * X = B or A' * X = B * with a general N-by-N matrix A using the LU factorization computed * by DGETRF. * * Arguments * ========= * * TRANS (input) CHARACTER*1 * Specifies the form of the system of equations: * = 'N': A * X = B (No transpose) * = 'T': A'* X = B (Transpose) * = 'C': A'* X = B (Conjugate transpose = Transpose) * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The factors L and U from the factorization A = P*L*U * as computed by DGETRF. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,N). * * IPIV (input) INTEGER array, dimension (N) * The pivot indices from DGETRF; for 1<=i<=N, row i of the * matrix was interchanged with row IPIV(i). * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLASWP, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A * X = B. * * Apply row interchanges to the right hand sides. * CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) * * Solve L*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve U*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) ELSE * * Solve A' * X = B. * * Solve U'*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, $ ONE, A, LDA, B, LDB ) * * Solve L'*X = B, overwriting B with X. * CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, $ A, LDA, B, LDB ) * * Apply row interchanges to the solution vectors. * CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) END IF * RETURN * * End of DGETRS * END SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 25, 1997 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * Purpose * ======= * * DPTSV computes the solution to a real system of linear equations * A*X = B, where A is an N-by-N symmetric positive definite tridiagonal * matrix, and X and B are N-by-NRHS matrices. * * A is factored as A = L*D*L**T, and the factored form of A is then * used to solve the system of equations. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the n diagonal elements of the tridiagonal matrix * A. On exit, the n diagonal elements of the diagonal matrix * D from the factorization A = L*D*L**T. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the (n-1) subdiagonal elements of the tridiagonal * matrix A. On exit, the (n-1) subdiagonal elements of the * unit bidiagonal factor L from the L*D*L**T factorization of * A. (E can also be regarded as the superdiagonal of the unit * bidiagonal factor U from the U**T*D*U factorization of A.) * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the N-by-NRHS right hand side matrix B. * On exit, if INFO = 0, the N-by-NRHS solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: if INFO = i, the leading minor of order i is not * positive definite, and the solution has not been * computed. The factorization has not been completed * unless i = N. * * ===================================================================== * * .. External Subroutines .. EXTERNAL DPTTRF, DPTTRS, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTSV ', -INFO ) RETURN END IF * * Compute the L*D*L' (or U'*D*U) factorization of A. * CALL DPTTRF( N, D, E, INFO ) IF( INFO.EQ.0 ) THEN * * Solve the system A*X = B, overwriting B with X. * CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO ) END IF RETURN * * End of DPTSV * END SUBROUTINE DPTTRF( N, D, E, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * Purpose * ======= * * DPTTRF computes the L*D*L' factorization of a real symmetric * positive definite tridiagonal matrix A. The factorization may also * be regarded as having the form A = U'*D*U. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the n diagonal elements of the tridiagonal matrix * A. On exit, the n diagonal elements of the diagonal matrix * D from the L*D*L' factorization of A. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the (n-1) subdiagonal elements of the tridiagonal * matrix A. On exit, the (n-1) subdiagonal elements of the * unit bidiagonal factor L from the L*D*L' factorization of A. * E can also be regarded as the superdiagonal of the unit * bidiagonal factor U from the U'*D*U factorization of A. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * > 0: if INFO = k, the leading minor of order k is not * positive definite; if k < N, the factorization could not * be completed, while if k = N, the factorization was * completed, but D(N) = 0. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, I4 DOUBLE PRECISION EI * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DPTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Compute the L*D*L' (or U'*D*U) factorization of A. * I4 = MOD( N-1, 4 ) DO 10 I = 1, I4 IF( D( I ).LE.ZERO ) THEN INFO = I GO TO 30 END IF EI = E( I ) E( I ) = EI / D( I ) D( I+1 ) = D( I+1 ) - E( I )*EI 10 CONTINUE * DO 20 I = I4 + 1, N - 4, 4 * * Drop out of the loop if d(i) <= 0: the matrix is not positive * definite. * IF( D( I ).LE.ZERO ) THEN INFO = I GO TO 30 END IF * * Solve for e(i) and d(i+1). * EI = E( I ) E( I ) = EI / D( I ) D( I+1 ) = D( I+1 ) - E( I )*EI * IF( D( I+1 ).LE.ZERO ) THEN INFO = I + 1 GO TO 30 END IF * * Solve for e(i+1) and d(i+2). * EI = E( I+1 ) E( I+1 ) = EI / D( I+1 ) D( I+2 ) = D( I+2 ) - E( I+1 )*EI * IF( D( I+2 ).LE.ZERO ) THEN INFO = I + 2 GO TO 30 END IF * * Solve for e(i+2) and d(i+3). * EI = E( I+2 ) E( I+2 ) = EI / D( I+2 ) D( I+3 ) = D( I+3 ) - E( I+2 )*EI * IF( D( I+3 ).LE.ZERO ) THEN INFO = I + 3 GO TO 30 END IF * * Solve for e(i+3) and d(i+4). * EI = E( I+3 ) E( I+3 ) = EI / D( I+3 ) D( I+4 ) = D( I+4 ) - E( I+3 )*EI 20 CONTINUE * * Check d(n) for positive definiteness. * IF( D( N ).LE.ZERO ) $ INFO = N * 30 CONTINUE RETURN * * End of DPTTRF * END SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER INFO, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * Purpose * ======= * * DPTTRS solves a tridiagonal system of the form * A * X = B * using the L*D*L' factorization of A computed by DPTTRF. D is a * diagonal matrix specified in the vector D, L is a unit bidiagonal * matrix whose subdiagonal is specified in the vector E, and X and B * are N by NRHS matrices. * * Arguments * ========= * * N (input) INTEGER * The order of the tridiagonal matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the diagonal matrix D from the * L*D*L' factorization of A. * * E (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) subdiagonal elements of the unit bidiagonal factor * L from the L*D*L' factorization of A. E can also be regarded * as the superdiagonal of the unit bidiagonal factor U from the * factorization A = U'*D*U. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side vectors B for the system of * linear equations. * On exit, the solution vectors, X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. INTEGER J, JB, NB * .. * .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV * .. * .. External Subroutines .. EXTERNAL DPTTS2, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * * Determine the number of right-hand sides to solve at a time. * IF( NRHS.EQ.1 ) THEN NB = 1 ELSE NB = MAX( 1, ILAENV( 1, 'DPTTRS', ' ', N, NRHS, -1, -1 ) ) END IF * IF( NB.GE.NRHS ) THEN CALL DPTTS2( N, NRHS, D, E, B, LDB ) ELSE DO 10 J = 1, NRHS, NB JB = MIN( NRHS-J+1, NB ) CALL DPTTS2( N, JB, D, E, B( 1, J ), LDB ) 10 CONTINUE END IF * RETURN * * End of DPTTRS * END SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) * * -- LAPACK routine (version 3.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1999 * * .. Scalar Arguments .. INTEGER LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * Purpose * ======= * * DPTTS2 solves a tridiagonal system of the form * A * X = B * using the L*D*L' factorization of A computed by DPTTRF. D is a * diagonal matrix specified in the vector D, L is a unit bidiagonal * matrix whose subdiagonal is specified in the vector E, and X and B * are N by NRHS matrices. * * Arguments * ========= * * N (input) INTEGER * The order of the tridiagonal matrix A. N >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the diagonal matrix D from the * L*D*L' factorization of A. * * E (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) subdiagonal elements of the unit bidiagonal factor * L from the L*D*L' factorization of A. E can also be regarded * as the superdiagonal of the unit bidiagonal factor U from the * factorization A = U'*D*U. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side vectors B for the system of * linear equations. * On exit, the solution vectors, X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. Executable Statements .. * * Quick return if possible * IF( N.LE.1 ) THEN IF( N.EQ.1 ) $ CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB ) RETURN END IF * * Solve A * X = B using the factorization A = L*D*L', * overwriting each right hand side vector with its solution. * DO 30 J = 1, NRHS * * Solve L * x = b. * DO 10 I = 2, N B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 ) 10 CONTINUE * * Solve D * L' * x = b. * B( N, J ) = B( N, J ) / D( N ) DO 20 I = N - 1, 1, -1 B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I ) 20 CONTINUE 30 CONTINUE * RETURN * * End of DPTTS2 * END